From 2f1b68ea4f4ec27736586f4b7ee29c63d30be3a4 Mon Sep 17 00:00:00 2001
From: rmkaplan <ron.kaplan@post.harvard.edu>
Date: Sat, 27 Feb 2021 22:01:14 -0800
Subject: [PATCH] MODERNIZE:  More work on attached windows, LOADUP-FULL with
 MODERNIZE replacing MACINTERFACE

---
 lispusers/MODERNIZE      |   2 +-
 lispusers/MODERNIZE.LCOM | Bin 7748 -> 7761 bytes
 sources/LOADUP-FULL      |   2 +-
 sources/LOADUP-FULL.LCOM | Bin 5728 -> 5778 bytes
 4 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/lispusers/MODERNIZE b/lispusers/MODERNIZE
index 37ff459a..89ee43a4 100644
--- a/lispusers/MODERNIZE
+++ b/lispusers/MODERNIZE
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED "22-Feb-2021 16:47:48" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;8
 20161  

      changes to%:  (VARS MODERNIZECOMS)
                    (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP 
                         MODERNWINDOW.BUTTONEVENTFN MODERN-ADD-EXEC MODERN-SNAPW TEDIT.MODERNIZE 
                         TOTOPW.MODERNIZE MODERNWINDOW.BUTTONEVENTFN.ANYWHERE 
                         MACWINDOW.BUTTONEVENTFN.ANYWHERE MACINT-ADD-EXEC TEDIT.MACINTERFACE 
                         TOTOPW.MACINTERFACE MACWINDOW.BUTTONEVENTFN INCORNER.REGION)

      previous date%: "22-Feb-2021 13:55:51" {DSK}<Users>kaplan>lisp>MACINTERFACE.;2)


(PRETTYCOMPRINT MODERNIZECOMS)

(RPAQQ MODERNIZECOMS

       [
        (* ;; "Externals")


        (COMS (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP)
              (INITVARS (MODERN-WINDOW-MARGIN 25)))
        
        (* ;; "Internals")


        [COMS (FNS MODERNWINDOW.BUTTONEVENTFN MODERNWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP 
                   NEARESTCORNER INCORNER.REGION)
              
              (* ;; "Behavior for some known window creators")


              (FNS MODERN-ADD-EXEC MODERN-SNAPW TOTOPW.MODERNIZE)
              
              (* ;; "Add some Meta commands")


              (FNS TEDIT.MODERNIZE TEDIT.SELECTALL)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MODERNIZE)
                                                 
                                                 (* ;; "Inspector")


                                                 (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER)
                                                 

                                 (* ;; "Commonlisp array inspector.  If you move the main window, the little attached window doesn't move.  But if you move the attached window, it all works.  Needs a special definition.  Shaping doesn't work either")


                                                 (* (MODERNWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN))
                                                 (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN)
                                                 
                                                 (* ;; "Freemenu")


                                                 (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN)
                                                 
                                                 (* ;; "SEDIT")


                                                 (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN)
                                                 
                                                 (* ;; "Debugger")


                                                 (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT)
                                                 
                                                 (* ;; "Snap")


                                                 (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW)
                                                 
                                                 (* ;; "New execs")


                                                 (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC)
                                                 
                                                 (* ;; "Existing exec of the load")


                                                 (MODERNWINDOW (PROCESSPROP (TTY.PROCESS)
                                                                      'WINDOW))
                                                 
                                                 (* ;; "Table browser (for filebrowser)")


                                                 (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN)
                                                 
                                                 (* ;; "Grapher")


                                                 (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE)
                                                 
                                                 (* ;; "Promptwindow")


                                                 (MODERNWINDOW PROMPTWINDOW T]
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA MODERN-ADD-EXEC])



(* ;; "Externals")


(DEFINEQ

(MODERNWINDOW

  [LAMBDA (WINDOW ANYWHERE)
                             (* ; "Edited 22-Feb-2021 16:44 by rmk:")


    (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")


    (CL:UNLESS (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)
        (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN))
        (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF
 ANYWHERE
                                              THEN
 (FUNCTION MODERNWINDOW.BUTTONEVENTFN.ANYWHERE)
                                            ELSE
 (FUNCTION MODERNWINDOW.BUTTONEVENTFN))))
    WINDOW])

(MODERNWINDOW.SETUP

  [LAMBDA (ORIGFN MODERNWINDOWFN ANYWHERE)
              (* ; "Edited 22-Feb-2021 16:42 by rmk:")


    (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.")


    (* ;; "Moves ORIGNFN to a new name, prefixed with MODERNORIG-.")


    (* ;; "If MODERNWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances.  This is typically the case where ORIGFN is a window creator.")


    (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into modern window operations.  If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.")


    (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.")


    (* ;; "The renamed function has arguments in addition to WINDOW:  the new name for the original function, if MODERNWINDOFN is provided, and the value specified here for ANYWHERE.")


    (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN]

         (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it")


         (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP")
                (SETQ PKGNAME "INTERLISP"))
         (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN)
                                  PKGNAME))
         (MOVD? ORIGFN RENAMEDORIG)
         (IF
 MODERNWINDOWFN
             THEN
 (MOVD MODERNWINDOWFN ORIGFN)
           ELSE
 (PUTD ORIGFN `(LAMBDA (WINDOW)
                                    (MODERNWINDOW.BUTTONEVENTFN
 WINDOW (FUNCTION ,RENAMEDORIG)
                                           ,ANYWHERE])

(UNMODERNWINDOW

  [LAMBDA (WINDOW)
                                      (* ; "Edited 22-Feb-2021 16:44 by rmk:")


    (* ;; "Restores original window behavior")


    (CL:WHEN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)
        (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN))
        (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN NIL))
    WINDOW])

(MODERNWINDOW.UNSETUP

  [LAMBDA (ORIGFN)
                                      (* ; "Edited 22-Feb-2021 16:45 by rmk:")


                                                            (* ; "Edited 24-Jun-2020 15:09 by rmk:")


    (* ;; "Moves the renamed original function back to its original name")


    (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN]

         (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it")


         (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP")
                (SETQ PKGNAME "INTERLISP"))
         (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN)
                                  PKGNAME))
         (CL:WHEN (GETD RENAMEDORIG)
                (MOVD RENAMEDORIG ORIGFN])
)

(RPAQ? MODERN-WINDOW-MARGIN
 25)



(* ;; "Internals")


(DEFINEQ

(MODERNWINDOW.BUTTONEVENTFN

  [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE)
                (* ; "Edited 22-Feb-2021 16:44 by rmk:")

    (IF
 (AND (MOUSESTATE (ONLY LEFT))
                 (EQ LASTKEYBOARD 0))
        THEN
 (TOTOPW WINDOW)
              (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION))
                          (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW]

                   (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window.  The TOPMARGIN should be 0 in that case.")


                   (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ")


                   (SETQ TOPMARGIN (IF
 (WINDOWPROP WINDOW 'TOPMARGIN)
                                     ELSEIF
 (WINDOWPROP WINDOW 'TITLE)
                                       THEN
 (FONTPROP WindowTitleDisplayStream 'HEIGHT)
                                     ELSE
 MODERN-WINDOW-MARGIN))
                   (SETQ CORNER (INCORNER.REGION
 MAINREGION TOPMARGIN))
                   (IF
 CORNER
                       THEN
 

                             (* ;; 

       "The upper corners may be in the title bar, near the side, so test corners before titlebar.")


                             (* ;; "We are in the corner of the main window, so we are reshaping.  But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.")


                             (* ;; "WINDOWREGION includes the attached windows")


                             (LET ((LEFT (FETCH
 LEFT OF
 ATTACHEDREGION))
                                   (RIGHT (FETCH
 RIGHT OF
 ATTACHEDREGION))
                                   (TOP (FETCH
 TOP OF
 ATTACHEDREGION))
                                   (BOTTOM (FETCH
 BOTTOM OF
 ATTACHEDREGION))
                                   STARTINGREGION)

                                 (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.")


                                  (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN))
                                      [SETQ STARTINGREGION
                                       (GETREGION NIL NIL NIL NIL NIL
                                              (SELECTQ CORNER
                                                  (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM)
                                                               (GETMOUSESTATE)
                                                               (LIST LEFT TOP RIGHT BOTTOM))
                                                  (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM)
                                                              (GETMOUSESTATE)
                                                              (LIST RIGHT TOP LEFT BOTTOM))
                                                  (RIGHTTOP (\CURSORPOSITION RIGHT TOP)
                                                            (GETMOUSESTATE)
                                                            (LIST LEFT BOTTOM RIGHT TOP))
                                                  (LEFTTOP (\CURSORPOSITION LEFT TOP)
                                                           (GETMOUSESTATE)
                                                           (LIST RIGHT BOTTOM LEFT TOP))
                                                  (SHOULDNT])
                                  (SHAPEW WINDOW STARTINGREGION))
                             T
                     ELSEIF
 (OR ANYWHERE (NEARTOP
 MAINREGION TOPMARGIN))
                       THEN
 (NEARESTCORNER
 ATTACHEDREGION)
                             (MOVEW WINDOW)
                             T
                     ELSEIF
 [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 
                                                                           'PREMODERN-BUTTONEVENTFN]
                       THEN
 (APPLY* ORIGFUNCTION WINDOW)))
      ELSEIF
 [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN]
        THEN
 (APPLY* ORIGFUNCTION WINDOW])

(MODERNWINDOW.BUTTONEVENTFN.ANYWHERE

  [LAMBDA (WINDOW)
                                      (* ; "Edited 22-Feb-2021 16:31 by rmk:")


                                                            (* ; "Edited 24-Jun-2020 13:24 by rmk:")


    (* ;; "Move if left-click anywhere, not just titlebar")


    (MODERNWINDOW.BUTTONEVENTFN
 WINDOW NIL T])

(NEARTOP

  [LAMBDA (MAINREGION TOPMARGIN)
                        (* ; "Edited 12-Feb-2021 23:19 by rmk:")


    (* ;; "True if the MOUSEY is near the top of MAINREGION.  That means in the title bar for titled windows, otherwise a short distance below the top of the window.  (Could be in the border?)")


    (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH
 TOP OF
 MAINREGION)
                                 TOPMARGIN])

(NEARESTCORNER

  [LAMBDA (REGION)
                                      (* ; "Edited 14-Feb-2021 21:46 by rmk:")


    (* ;; 

"Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY")


    (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH
 LEFT OF
 REGION))
                                   (IDIFFERENCE (FETCH
 RIGHT OF
 REGION)
                                          LASTMOUSEX))
                         (FETCH
 LEFT OF
 REGION)
                         (FETCH
 RIGHT OF
 REGION))
           (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH
 BOTTOM OF
 REGION))
                         (IDIFFERENCE (FETCH
 TOP OF
 REGION)
                                LASTMOUSEY))
               (FETCH
 BOTTOM OF
 REGION)
               (FETCH
 TOP OF
 REGION))])

(INCORNER.REGION

  [LAMBDA (MAINREGION TOPMARGIN)
                        (* ; "Edited 22-Feb-2021 16:27 by rmk:")


    (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.")


    (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ")


    (IF
 (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH
 LEFT OF
 MAINREGION)))
                  MODERN-WINDOW-MARGIN)
        THEN
 (IF
 (NEARTOP
 MAINREGION TOPMARGIN)
                     THEN
 'LEFTTOP
                   ELSEIF
 (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH
 BOTTOM
                                                                              OF
 MAINREGION)))
                     THEN
 'LEFTBOTTOM)
      ELSEIF
 (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH
 RIGHT OF
 MAINREGION)))
                       MODERN-WINDOW-MARGIN)
        THEN
 (IF
 (NEARTOP
 MAINREGION TOPMARGIN)
                     THEN
 'RIGHTTOP
                   ELSEIF
 (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH
 BOTTOM
                                                                              OF
 MAINREGION)))
                     THEN
 'RIGHTBOTTOM])
)



(* ;; "Behavior for some known window creators")


(DEFINEQ

(MODERN-ADD-EXEC

  [LAMBDA U
                                             (* ; "Edited 22-Feb-2021 16:41 by rmk:")

    (LET [(PROC (APPLY (FUNCTION MODERN-ORIG-ADD-EXEC)
                       (FOR
 N FROM
 1 TO
 U COLLECT
 (ARG U N]

         (* ;; "For some reason, the window may not be there immediately")


         (DISMISS 100)
         (MODERNWINDOW
 (PROCESSPROP PROC 'WINDOW))
         PROC])

(MODERN-SNAPW

  [LAMBDA NIL
                                           (* ; "Edited 22-Feb-2021 16:41 by rmk:")


    (* ;; "No point in shaping a snap window, just move it.;;")


    (* ;; 

"This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN")


    (LET ((W (MODERN-ORIG-SNAPW)))
         [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W)
                                                  (TOTOPW W)
                                                  (MOVEW W]
         W])

(TOTOPW.MODERNIZE

  [LAMBDA (WINDOW)
                                      (* ; "Edited 22-Feb-2021 16:31 by rmk:")


    (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.")


    (TOTOPW WINDOW)
    (LET ((MAIN (MAINWINDOW WINDOW T)))
         (CL:WHEN MAIN
             (MODERNWINDOW.BUTTONEVENTFN
 MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))])
)



(* ;; "Add some Meta commands")


(DEFINEQ

(TEDIT.MODERNIZE

  [LAMBDA NIL
                                           (* ; "Edited 22-Feb-2021 16:28 by rmk:")

    (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN)
        (MODERNWINDOW.SETUP
 '\TEDIT.BUTTONEVENTFN)

        (* ;; "All")


        (TEDIT.SETFUNCTION (CHARCODE "1,a")
               (FUNCTION TEDIT.SELECTALL)
               TEDIT.READTABLE)
        (TEDIT.SETFUNCTION (CHARCODE "1,A")
               (FUNCTION TEDIT.SELECTALL)
               TEDIT.READTABLE)

        (* ;; "Quit")


        (TEDIT.SETFUNCTION (CHARCODE "1,q")
               (FUNCTION TEDIT.QUIT)
               TEDIT.READTABLE)
        (TEDIT.SETFUNCTION (CHARCODE "1,Q")
               (FUNCTION TEDIT.QUIT)
               TEDIT.READTABLE))])

(TEDIT.SELECTALL

  [LAMBDA (STREAM TEXTOBJ SEL)
                          (* ; "Edited  3-May-2020 17:29 by rmk:")

    (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS]
         (CL:WHEN TEXTSTREAM
             (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch
 TEXTLEN of
 (TEXTOBJ TEXTSTREAM)))
                    'LEFT))])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(TEDIT.MODERNIZE
)


(* ;; "Inspector")



(MODERNWINDOW.SETUP
 '\ITEM.WINDOW.BUTTON.HANDLER)


(* ;; "Commonlisp array inspector.  If you move the main window, the little attached window doesn't move.  But if you move the attached window, it all works.  Needs a special definition.  Shaping doesn't work either")



                                                             (* (MODERNWINDOW.SETUP

                                                           (QUOTE ONEDINSPECT.BUTTONEVENTFN)))


(MODERNWINDOW.SETUP
 'ICMLARRAY.TITLECOMMANDFN)


(* ;; "Freemenu")



(MODERNWINDOW.SETUP
 '\FM.BUTTONEVENTFN)


(* ;; "SEDIT")



(MODERNWINDOW.SETUP
 'SEDIT::BUTTONEVENTFN)


(* ;; "Debugger")



(MODERNWINDOW.SETUP
 'DBG::DEBUGGER-BUTTON-EVENT)


(* ;; "Snap")



(MODERNWINDOW.SETUP
 'SNAPW 'MODERN-SNAPW)


(* ;; "New execs")



(MODERNWINDOW.SETUP
 'ADD-EXEC 'MODERN-ADD-EXEC)


(* ;; "Existing exec of the load")



(MODERNWINDOW
 (PROCESSPROP (TTY.PROCESS)
                         'WINDOW))


(* ;; "Table browser (for filebrowser)")



(MODERNWINDOW.SETUP
 'TB.BUTTONEVENTFN)


(* ;; "Grapher")



(MODERNWINDOW.SETUP
 'APPLYTOSELECTEDNODE)


(* ;; "Promptwindow")



(MODERNWINDOW
 PROMPTWINDOW T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 MODERN-ADD-EXEC)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4575 8401 (MODERNWINDOW 4585 . 5243) (MODERNWINDOW.SETUP 5245 . 7189) (UNMODERNWINDOW 
7191 . 7585) (MODERNWINDOW.UNSETUP 7587 . 8399)) (8466 16070 (MODERNWINDOW.BUTTONEVENTFN 8476 . 13078)
 (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE 13080 . 13451) (NEARTOP 13453 . 13889) (NEARESTCORNER 13891 . 
14770) (INCORNER.REGION 14772 . 16068)) (16128 17546 (MODERN-ADD-EXEC 16138 . 16569) (MODERN-SNAPW 
16571 . 17114) (TOTOPW.MODERNIZE 17116 . 17544)) (17587 18670 (TEDIT.MODERNIZE 17597 . 18339) (
TEDIT.SELECTALL 18341 . 18668)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED "27-Feb-2021 18:14:36" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;11
 20163  

      changes to%:  (FNS MODERNWINDOW.BUTTONEVENTFN)

      previous date%: "26-Feb-2021 21:20:15" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MODERNIZE.;10)


(PRETTYCOMPRINT MODERNIZECOMS)

(RPAQQ MODERNIZECOMS

       [
        (* ;; "Externals")


        (COMS (FNS MODERNWINDOW MODERNWINDOW.SETUP UNMODERNWINDOW MODERNWINDOW.UNSETUP)
              (INITVARS (MODERN-WINDOW-MARGIN 25)))
        
        (* ;; "Internals")


        [COMS (FNS MODERNWINDOW.BUTTONEVENTFN MODERNWINDOW.BUTTONEVENTFN.ANYWHERE NEARTOP 
                   NEARESTCORNER INCORNER.REGION)
              
              (* ;; "Behavior for some known window creators")


              (FNS MODERN-ADD-EXEC MODERN-SNAPW TOTOPW.MODERNIZE)
              
              (* ;; "Add some Meta commands")


              (FNS TEDIT.MODERNIZE TEDIT.SELECTALL)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MODERNIZE)
                                                 
                                                 (* ;; "Inspector")


                                                 (MODERNWINDOW.SETUP '\ITEM.WINDOW.BUTTON.HANDLER)
                                                 

                                 (* ;; "Commonlisp array inspector.  If you move the main window, the little attached window doesn't move.  But if you move the attached window, it all works.  Needs a special definition.  Shaping doesn't work either")


                                                 (* (MODERNWINDOW.SETUP 'ONEDINSPECT.BUTTONEVENTFN))
                                                 (MODERNWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN)
                                                 
                                                 (* ;; "Freemenu")


                                                 (MODERNWINDOW.SETUP '\FM.BUTTONEVENTFN)
                                                 
                                                 (* ;; "SEDIT")


                                                 (MODERNWINDOW.SETUP 'SEDIT::BUTTONEVENTFN)
                                                 
                                                 (* ;; "Debugger")


                                                 (MODERNWINDOW.SETUP 'DBG::DEBUGGER-BUTTON-EVENT)
                                                 
                                                 (* ;; "Snap")


                                                 (MODERNWINDOW.SETUP 'SNAPW 'MODERN-SNAPW)
                                                 
                                                 (* ;; "New execs")


                                                 (MODERNWINDOW.SETUP 'ADD-EXEC 'MODERN-ADD-EXEC)
                                                 
                                                 (* ;; "Existing exec of the load")


                                                 (MODERNWINDOW (PROCESSPROP (TTY.PROCESS)
                                                                      'WINDOW))
                                                 
                                                 (* ;; "Table browser (for filebrowser)")


                                                 (MODERNWINDOW.SETUP 'TB.BUTTONEVENTFN)
                                                 
                                                 (* ;; "Grapher")


                                                 (MODERNWINDOW.SETUP 'APPLYTOSELECTEDNODE)
                                                 
                                                 (* ;; "Promptwindow")


                                                 (MODERNWINDOW PROMPTWINDOW T]
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA MODERN-ADD-EXEC])



(* ;; "Externals")


(DEFINEQ

(MODERNWINDOW

  [LAMBDA (WINDOW ANYWHERE)
                             (* ; "Edited 22-Feb-2021 16:44 by rmk:")


    (* ;; "This can be applied to windows that have been created with an unknown or unmodifiable buttoneventfn.")


    (CL:UNLESS (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)
        (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN))
        (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF
 ANYWHERE
                                              THEN
 (FUNCTION MODERNWINDOW.BUTTONEVENTFN.ANYWHERE)
                                            ELSE
 (FUNCTION MODERNWINDOW.BUTTONEVENTFN))))
    WINDOW])

(MODERNWINDOW.SETUP

  [LAMBDA (ORIGFN MODERNWINDOWFN ANYWHERE)
              (* ; "Edited 22-Feb-2021 16:42 by rmk:")


    (* ;; "ORIGFN is either a function that creates windows of a given type (e.g. SNAPW or ADD-EXEC) or the known BUTTONEVENTFN of a class of windows.")


    (* ;; "Moves ORIGNFN to a new name, prefixed with MODERNORIG-.")


    (* ;; "If MODERNWINDOWFN is given, then that replaces the original definition of ORIGFN, and presumably knows how to call the renamed ORIGFN under the right circumstances.  This is typically the case where ORIGFN is a window creator.")


    (* ;; "Otherwise, ORIGFN is taken to be the BUTTONEVENTFN for a class of windows, and its new definition is defaulted to one that maps left-clicks in appropriate areas into modern window operations.  If not in appropriate areas, then the renamed ORIGNFN is called to give the original button behavior.")


    (* ;; "If ANYWHERE, moving will happen for any click not in one of the shaping corners.")


    (* ;; "The renamed function has arguments in addition to WINDOW:  the new name for the original function, if MODERNWINDOFN is provided, and the value specified here for ANYWHERE.")


    (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN]

         (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it")


         (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP")
                (SETQ PKGNAME "INTERLISP"))
         (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN)
                                  PKGNAME))
         (MOVD? ORIGFN RENAMEDORIG)
         (IF
 MODERNWINDOWFN
             THEN
 (MOVD MODERNWINDOWFN ORIGFN)
           ELSE
 (PUTD ORIGFN `(LAMBDA (WINDOW)
                                    (MODERNWINDOW.BUTTONEVENTFN
 WINDOW (FUNCTION ,RENAMEDORIG)
                                           ,ANYWHERE])

(UNMODERNWINDOW

  [LAMBDA (WINDOW)
                                      (* ; "Edited 22-Feb-2021 16:44 by rmk:")


    (* ;; "Restores original window behavior")


    (CL:WHEN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN)
        (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN))
        (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN NIL))
    WINDOW])

(MODERNWINDOW.UNSETUP

  [LAMBDA (ORIGFN)
                                      (* ; "Edited 22-Feb-2021 16:45 by rmk:")


                                                            (* ; "Edited 24-Jun-2020 15:09 by rmk:")


    (* ;; "Moves the renamed original function back to its original name")


    (LET [RENAMEDORIG (PKGNAME (CL:PACKAGE-NAME (CL:SYMBOL-PACKAGE ORIGFN]

         (* ;; "The renamed version of XCL symbols go into Interlisp, so there is less confusion about accessing it")


         (CL:WHEN (STREQUAL PKGNAME "XEROX-COMMON-LISP")
                (SETQ PKGNAME "INTERLISP"))
         (SETQ RENAMEDORIG (CL:INTERN (CONCAT 'MODERN-ORIG- ORIGFN)
                                  PKGNAME))
         (CL:WHEN (GETD RENAMEDORIG)
                (MOVD RENAMEDORIG ORIGFN])
)

(RPAQ? MODERN-WINDOW-MARGIN
 25)



(* ;; "Internals")


(DEFINEQ

(MODERNWINDOW.BUTTONEVENTFN

  [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE)
                (* ; "Edited 27-Feb-2021 17:57 by rmk:")

    (IF
 (AND (MOUSESTATE (ONLY LEFT))
                 (EQ LASTKEYBOARD 0))
        THEN
 (TOTOPW WINDOW)
              (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION))
                          (ATTACHEDREGION (ATTACHEDWINDOWREGION (CENTRALWINDOW WINDOW]

                   (* ;; "If the window has a TOPMARGIN property, that tells us that it does not have a canonical title but may still have a title-like attached window just above the main window.  The TOPMARGIN should be 0 in that case.")


                   (* ;; "This is particularly the case of FILEBROWSER windows, where the the modified ATTACHEDWINDOWTOTOPFN drives the click here. ")


                   (SETQ TOPMARGIN (IF
 (WINDOWPROP WINDOW 'TOPMARGIN)
                                     ELSEIF
 (WINDOWPROP WINDOW 'TITLE)
                                       THEN
 (FONTPROP WindowTitleDisplayStream 'HEIGHT)
                                     ELSE
 MODERN-WINDOW-MARGIN))
                   (SETQ CORNER (INCORNER.REGION
 MAINREGION TOPMARGIN))
                   (IF
 CORNER
                       THEN
 

                             (* ;; 

       "The upper corners may be in the title bar, near the side, so test corners before titlebar.")


                             (* ;; "We are in the corner of the main window, so we are reshaping.  But the ghost region should include all of the attached windows, and the starting cursor should be positioned at the corner closest to the selected corner of the main window.")


                             (* ;; "WINDOWREGION includes the attached windows")


                             (LET ((LEFT (FETCH
 LEFT OF
 ATTACHEDREGION))
                                   (RIGHT (FETCH
 RIGHT OF
 ATTACHEDREGION))
                                   (TOP (FETCH
 TOP OF
 ATTACHEDREGION))
                                   (BOTTOM (FETCH
 BOTTOM OF
 ATTACHEDREGION))
                                   STARTINGREGION)

                                 (* ;; "\CURSORPOSITION moves the mouse to the tracking corner of the ghost region, in screen coordinates, so that the mouse starts out at the tracking corner of the ghost region, even if there are attached windows (as in the filebrowser) that overhang the corner and the initiating click was at the corner of the mainwindow.")


                                  (CL:UNLESS (EQ 'DON'T (WINDOWPROP WINDOW 'RESHAPEFN))
                                      [SETQ STARTINGREGION
                                       (GETREGION NIL NIL NIL NIL NIL
                                              (SELECTQ CORNER
                                                  (RIGHTBOTTOM (\CURSORPOSITION RIGHT BOTTOM)
                                                               (GETMOUSESTATE)
                                                               (LIST LEFT TOP RIGHT BOTTOM))
                                                  (LEFTBOTTOM (\CURSORPOSITION LEFT BOTTOM)
                                                              (GETMOUSESTATE)
                                                              (LIST RIGHT TOP LEFT BOTTOM))
                                                  (RIGHTTOP (\CURSORPOSITION RIGHT TOP)
                                                            (GETMOUSESTATE)
                                                            (LIST LEFT BOTTOM RIGHT TOP))
                                                  (LEFTTOP (\CURSORPOSITION LEFT TOP)
                                                           (GETMOUSESTATE)
                                                           (LIST RIGHT BOTTOM LEFT TOP))
                                                  (SHOULDNT])
                                  (SHAPEW (CL:IF (MEMB 'SHAPEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS))
                                              (WINDOWPROP WINDOW 'MAINWINDOW)
                                              WINDOW)
                                         STARTINGREGION))
                             T
                     ELSEIF
 (OR ANYWHERE (NEARTOP
 MAINREGION TOPMARGIN))
                       THEN
 (NEARESTCORNER
 ATTACHEDREGION)
                             (MOVEW (CL:IF (MEMB 'MOVEW (WINDOWPROP WINDOW 'PASSTOMAINCOMS))
                                        (WINDOWPROP WINDOW 'MAINWINDOW)
                                        WINDOW))
                             T
                     ELSEIF
 [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 
                                                                           'PREMODERN-BUTTONEVENTFN]
                       THEN
 (APPLY* ORIGFUNCTION WINDOW)))
      ELSEIF
 [OR ORIGFUNCTION (SETQ ORIGFUNCTION (WINDOWPROP WINDOW 'PREMODERN-BUTTONEVENTFN]
        THEN
 (APPLY* ORIGFUNCTION WINDOW])

(MODERNWINDOW.BUTTONEVENTFN.ANYWHERE

  [LAMBDA (WINDOW)
                                      (* ; "Edited 22-Feb-2021 16:31 by rmk:")


                                                            (* ; "Edited 24-Jun-2020 13:24 by rmk:")


    (* ;; "Move if left-click anywhere, not just titlebar")


    (MODERNWINDOW.BUTTONEVENTFN
 WINDOW NIL T])

(NEARTOP

  [LAMBDA (MAINREGION TOPMARGIN)
                        (* ; "Edited 12-Feb-2021 23:19 by rmk:")


    (* ;; "True if the MOUSEY is near the top of MAINREGION.  That means in the title bar for titled windows, otherwise a short distance below the top of the window.  (Could be in the border?)")


    (IGREATERP LASTMOUSEY (IDIFFERENCE (FETCH
 TOP OF
 MAINREGION)
                                 TOPMARGIN])

(NEARESTCORNER

  [LAMBDA (REGION)
                                      (* ; "Edited 14-Feb-2021 21:46 by rmk:")


    (* ;; 

"Moves the cursor to the corner of REGION that is closest to the current LASTMOUSEX AND LASTMOUSEY")


    (\CURSORPOSITION (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEX (FETCH
 LEFT OF
 REGION))
                                   (IDIFFERENCE (FETCH
 RIGHT OF
 REGION)
                                          LASTMOUSEX))
                         (FETCH
 LEFT OF
 REGION)
                         (FETCH
 RIGHT OF
 REGION))
           (CL:IF (ILESSP (IDIFFERENCE LASTMOUSEY (FETCH
 BOTTOM OF
 REGION))
                         (IDIFFERENCE (FETCH
 TOP OF
 REGION)
                                LASTMOUSEY))
               (FETCH
 BOTTOM OF
 REGION)
               (FETCH
 TOP OF
 REGION))])

(INCORNER.REGION

  [LAMBDA (MAINREGION TOPMARGIN)
                        (* ; "Edited 22-Feb-2021 16:27 by rmk:")


    (* ;; "MAINREGION, LASTMOUSEX, LASTMOUSEY in screen coordinates.")


    (* ;; "TOPMARGIN is the height of the titlebar for titled windows, otherwise the margin at the top of the window's content that we regard as the top. ")


    (IF
 (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH
 LEFT OF
 MAINREGION)))
                  MODERN-WINDOW-MARGIN)
        THEN
 (IF
 (NEARTOP
 MAINREGION TOPMARGIN)
                     THEN
 'LEFTTOP
                   ELSEIF
 (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH
 BOTTOM
                                                                              OF
 MAINREGION)))
                     THEN
 'LEFTBOTTOM)
      ELSEIF
 (ILEQ (IABS (IDIFFERENCE LASTMOUSEX (FETCH
 RIGHT OF
 MAINREGION)))
                       MODERN-WINDOW-MARGIN)
        THEN
 (IF
 (NEARTOP
 MAINREGION TOPMARGIN)
                     THEN
 'RIGHTTOP
                   ELSEIF
 (ILEQ LASTMOUSEY (IPLUS MODERN-WINDOW-MARGIN (FETCH
 BOTTOM
                                                                              OF
 MAINREGION)))
                     THEN
 'RIGHTBOTTOM])
)



(* ;; "Behavior for some known window creators")


(DEFINEQ

(MODERN-ADD-EXEC

  [LAMBDA U
                                             (* ; "Edited 22-Feb-2021 16:41 by rmk:")

    (LET [(PROC (APPLY (FUNCTION MODERN-ORIG-ADD-EXEC)
                       (FOR
 N FROM
 1 TO
 U COLLECT
 (ARG U N]

         (* ;; "For some reason, the window may not be there immediately")


         (DISMISS 100)
         (MODERNWINDOW
 (PROCESSPROP PROC 'WINDOW))
         PROC])

(MODERN-SNAPW

  [LAMBDA NIL
                                           (* ; "Edited 22-Feb-2021 16:41 by rmk:")


    (* ;; "No point in shaping a snap window, just move it.;;")


    (* ;; 

"This changes the creation function (SNAPW), since snap windows otherwise don't have a BUTTONEVENTN")


    (LET ((W (MODERN-ORIG-SNAPW)))
         [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W)
                                                  (TOTOPW W)
                                                  (MOVEW W]
         W])

(TOTOPW.MODERNIZE

  [LAMBDA (WINDOW)
                                      (* ; "Edited 22-Feb-2021 16:31 by rmk:")


    (* ;; "This replaces the TOTOPW BUTTONEVENTFN on an attached window where the click is then directed to the MAINWINDOW.")


    (TOTOPW WINDOW)
    (LET ((MAIN (MAINWINDOW WINDOW T)))
         (CL:WHEN MAIN
             (MODERNWINDOW.BUTTONEVENTFN
 MAIN (WINDOWPROP MAIN 'BUTTONEVENTFN)))])
)



(* ;; "Add some Meta commands")


(DEFINEQ

(TEDIT.MODERNIZE

  [LAMBDA NIL
                                           (* ; "Edited 22-Feb-2021 16:28 by rmk:")

    (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN)
        (MODERNWINDOW.SETUP
 '\TEDIT.BUTTONEVENTFN)

        (* ;; "All")


        (TEDIT.SETFUNCTION (CHARCODE "1,a")
               (FUNCTION TEDIT.SELECTALL)
               TEDIT.READTABLE)
        (TEDIT.SETFUNCTION (CHARCODE "1,A")
               (FUNCTION TEDIT.SELECTALL)
               TEDIT.READTABLE)

        (* ;; "Quit")


        (TEDIT.SETFUNCTION (CHARCODE "1,q")
               (FUNCTION TEDIT.QUIT)
               TEDIT.READTABLE)
        (TEDIT.SETFUNCTION (CHARCODE "1,Q")
               (FUNCTION TEDIT.QUIT)
               TEDIT.READTABLE))])

(TEDIT.SELECTALL

  [LAMBDA (STREAM TEXTOBJ SEL)
                          (* ; "Edited  3-May-2020 17:29 by rmk:")

    (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS]
         (CL:WHEN TEXTSTREAM
             (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch
 TEXTLEN of
 (TEXTOBJ TEXTSTREAM)))
                    'LEFT))])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(TEDIT.MODERNIZE
)


(* ;; "Inspector")



(MODERNWINDOW.SETUP
 '\ITEM.WINDOW.BUTTON.HANDLER)


(* ;; "Commonlisp array inspector.  If you move the main window, the little attached window doesn't move.  But if you move the attached window, it all works.  Needs a special definition.  Shaping doesn't work either")



                                                             (* (MODERNWINDOW.SETUP

                                                           (QUOTE ONEDINSPECT.BUTTONEVENTFN)))


(MODERNWINDOW.SETUP
 'ICMLARRAY.TITLECOMMANDFN)


(* ;; "Freemenu")



(MODERNWINDOW.SETUP
 '\FM.BUTTONEVENTFN)


(* ;; "SEDIT")



(MODERNWINDOW.SETUP
 'SEDIT::BUTTONEVENTFN)


(* ;; "Debugger")



(MODERNWINDOW.SETUP
 'DBG::DEBUGGER-BUTTON-EVENT)


(* ;; "Snap")



(MODERNWINDOW.SETUP
 'SNAPW 'MODERN-SNAPW)


(* ;; "New execs")



(MODERNWINDOW.SETUP
 'ADD-EXEC 'MODERN-ADD-EXEC)


(* ;; "Existing exec of the load")



(MODERNWINDOW
 (PROCESSPROP (TTY.PROCESS)
                         'WINDOW))


(* ;; "Table browser (for filebrowser)")



(MODERNWINDOW.SETUP
 'TB.BUTTONEVENTFN)


(* ;; "Grapher")



(MODERNWINDOW.SETUP
 'APPLYTOSELECTEDNODE)


(* ;; "Promptwindow")



(MODERNWINDOW
 PROMPTWINDOW T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 MODERN-ADD-EXEC)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4168 7994 (MODERNWINDOW 4178 . 4836) (MODERNWINDOW.SETUP 4838 . 6782) (UNMODERNWINDOW 
6784 . 7178) (MODERNWINDOW.UNSETUP 7180 . 7992)) (8059 16072 (MODERNWINDOW.BUTTONEVENTFN 8069 . 13080)
 (MODERNWINDOW.BUTTONEVENTFN.ANYWHERE 13082 . 13453) (NEARTOP 13455 . 13891) (NEARESTCORNER 13893 . 
14772) (INCORNER.REGION 14774 . 16070)) (16130 17548 (MODERN-ADD-EXEC 16140 . 16571) (MODERN-SNAPW 
16573 . 17116) (TOTOPW.MODERNIZE 17118 . 17546)) (17589 18672 (TEDIT.MODERNIZE 17599 . 18341) (
TEDIT.SELECTALL 18343 . 18670)))))
STOP
\ No newline at end of file
diff --git a/lispusers/MODERNIZE.LCOM b/lispusers/MODERNIZE.LCOM
index dd9ee7b19a9fe657b7ca48bee61fe80eb830cebd..189ea08d435d4f7fb0206ec8a8555e32f67313b3 100644
GIT binary patch
delta 639
zcmah^Jx|+E6s;3Pl>}FjU_g}N5(xpSu>3yq{2_)I=ee<p?O<C(ol0n;6oyjD$J}2~
zHF{&)g()j!=@01A5u}d&3stAiwO^2EOQpWyzVpsK=brmMZ(MD>3uldWufMmBb&LR+
zHlj9R!|qN2q2VV@EKNNeeqY>Xw;D~;YS8PR^n0Mz@NW%_Y|3n6)z;Ki&)?#1%$<}s
zp@#pJaO5o_1XxFm!1EW~mxKN>oE$FOu<C^gs9EsB${M_S-9OtuJUy0yS@Z8etlOwQ
zJn{-iANPvJv~n#zl;)R4yZ5ql@Z<bK`PeAscv8PiPwtZVS|SBS5#{prvw`f(TF#*?
z?;E$on?_WX<bHK?)OsS}CHCdq|C`0nvRR~cDo|y%ND0bsl_CZ~w8J|<bt_}$DwY8O
z4>o~VIDbDf7=+x3d6K$O9P$_lGbNKoZ6I|6l9toX{Dhj)PqKm1FB9g*Zz~U!WhYG?
zx5b+sKWs*wm_PQT5b6kA9;UIgHKE05Mk`WkiSGURDWI6;;AyrPg~0K{i3o^kK-)=@
hG|EXg3X+UMH=iJs{Gr9{juz`T8w*u!j|b|v>MwI)k~jbW

delta 620
zcmY*VO>fgc5RGG$G^Un<s4G!{vWf(1kYZ*1kwk73#n>BamFz~g6IVUe6gLS(NvH#t
zil2Z)S#jh57tW|BPJqM(aX|0`;KZGufbFOy-NWpgw{PC;%#X&G#tVE^Dz}6CWvL=T
z0IQl()0Fy&-)HJ4AH?irIv<WE1IjQr7>O1bK`TnjdPP&9rYgk}zuC6#A;U(xi%f7)
zbY}XveY*~%3amnKF!U#bAO!R2O$}`Jb=v`ahnUF5)*doQ$0^aFpweT3&-So`++LS{
zXRgy%>xBX`Emu6(0++a?>-{GZ9bq}PqZ{;1c8x}OE5a6b%erZn(JnFoAAK@*NoZuZ
zbpxFnEprPGVc)_Au`#km8{M@CE`ixm@N_hN5`qW*Jcvf%FHS6Ls;a552#!r>=UJl{
z21jA@kv|*zlje97&YH`e#VzS{FI~%M&vWS%yON5|$Ne~tvwy~y{=R+B93<((81A-m
z@zWxH&9nw_#?fypays?<W$x!ji{!bO8|Cl3+uljwYb&XtkgKzDU8SG7HKs~GaRO9o
zphNn|1F`}EM!Jn0cQGlDWhG&v?E+bnfwQf5k#`C&=b2T{!Y1(+yP$`wV&qz(S2EXF
US*=C)2EE1OoC?osLjG6&ANVMs*8l(j

diff --git a/sources/LOADUP-FULL b/sources/LOADUP-FULL
index df325f60..f5abef01 100644
--- a/sources/LOADUP-FULL
+++ b/sources/LOADUP-FULL
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED " 6-Feb-2021 15:41:34" {DSK}<home>larry>ilisp>medley>sources>LOADUP-FULL.;3
 7916   

      changes to%:  (VARS LOADUP-FULLCOMS)

      previous date%: " 6-Feb-2021 13:46:58" {DSK}<home>larry>ilisp>medley>sources>LOADUP-FULL.;2)


(PRETTYCOMPRINT LOADUP-FULLCOMS)

(RPAQQ LOADUP-FULLCOMS

       ((COMMANDS "cd" "pwd" "ls")
        (FNS LOADFULLFONTS MAKEFULLSYSOUT FIXMETA)
        (P (FIXMETA))
        (VARS (WRITEFULLSYSOUTFLAG T))
        (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
        (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAKEFULLSYSOUT)))
        (PROP FILETYPE)))

(DEFCOMMAND "cd" (DIR) (/CNDIR DIR))

(DEFCOMMAND "pwd" NIL (DIRECTORYNAME T))

(DEFCOMMAND "ls" (FIRST
 . REST) (DODIR (CONS FIRST REST)))
(DEFINEQ

(LOADFULLFONTS

  [LAMBDA (ROOTDIRECTORY)                                    (* ; 

                                                           "Edited 11-Aug-2020 17:53 by rmk:")


    (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q")


    (PRINTOUT T "Loading FULL fonts..." T)
    (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts")
                                       (PACK* ROOTDIRECTORY "/fonts/altofonts")))
                                                             (* (SETQ INTERPRESSFONTDIRECTORIES

                                                           (CONS (PACK* ROOTDIRECTORY 

                                                           "/fonts/ipfonts"))))

    (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE))
    (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts")))
    (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT)
    (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL)
                (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL))    (* ; 

                  "Don't let the font loader substitute just because a server went catatonic on us")

               (for
 FAMILY in
 '(CLASSIC MODERN TERMINAL)
                  do
 (PRINTOUT T "  Loading " FAMILY " ")
                        [for
 SIZE in
 '(8 10 12)
                           do
 (PRINTOUT T SIZE " ")
                                 (for
 FACE in
 '(MRR BRR MIR)
                                    do
 

                                          (* ;; "No need for Interpress")

                                                             (* (NLSETQ (FONTCREATE FAMILY SIZE 

                                                           FACE NIL (QUOTE INTERPRESS) NIL 0)))

                                          (for
 CSET
                                             in
 '(0 33 34 35 238 239 241)
                                             do
 (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL
                                                                   'DISPLAY NIL CSET]
                        (PRINTOUT T T))
               (PRINTOUT T "  Loading postscript fonts" T)
               (for
 F in
 (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES)
                                                ">c0>*.*")) do
 (PSCFONT.READFONT F))
               (PRINTOUT T "FULL fonts loaded" T])

(MAKEFULLSYSOUT

  [LAMBDA NIL
                                          (* ; "Edited  5-Dec-2020 20:07 by larry")

                                                             (* ; 

                                                           "Edited 14-May-2018 15:01 by kaplan")

                                                             (* ; 

                                                           "Edited 28-Sep-2020 12:35 by rmk:")

                                                             (* ; "Edited 17-Apr-2018 08:41 by ")

                                                             (* ; 

                                                           "Edited 21-Apr-2018 07:27 by rmk:")

                                                             (* ; "Edited 23-Feb-94 15:04 by bvm")

    (CLRPROMPT)
    (CNDIR (UNIX-GETENV "LOADUPDIR"))
    (LET ((ROOTDIRECTORY (MEDLEYDIR)))
         (SETQ MAKESYSFILENAME (CONCAT (MEDLEYDIR "loadups")
                                      "xfull35.sysout"))
         (DRIBBLE (PACKFILENAME 'EXTENSION 'DRIBBLE 'BODY MAKESYSFILENAME))

         (* ;; "BKSYSBUF stops page holding ")


         (PRINTOUT T T "Full loadup started at " (DATE)
                " while connected to "
                (DIRECTORYNAME T)
                T T)
         (BKSYSBUF " ")
         (SETQ DEFAULTFILETYPE 'BINARY)                      (* ; 

                                      "These prevent bits from being lost due to lack of knowledge")

         (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST)
                DEFAULTFILETYPELIST)                         (* (SETQ *UPPER-CASE-FILE-NAMES* NIL))

         (SETQ MAKESYSNAME :MEDLEY3.5)
         (push
 DEFAULTFILETYPELIST '(TXT . TEXT)
                '(TEXT . TEXT)
                '(TEX . TEXT)
                '(HTML . TEXT)
                '(HTM . TEXT))
         (MEDLEY-INIT-VARS)
         (SETQ LOADUPDIRECTORIES DIRECTORIES)
         (LOADUP '(POSTSCRIPTSTREAM))                        (* ; " to get PSCFONT.READFONT")

         (LOADFULLFONTS
 (MEDLEYDIR))
         (LISTPUT IDLE.PROFILE 'TIMEOUT 0)
         (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
         (LOADUP '(CHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES GRAPHER SPY
                        WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT UNICODE ISO8859IO
                        HELPSYS DINFO CLIPBOARD MACINTERFACE))
         (FILESLOAD (SYSLOAD)
                PRETTYFILEINDEX WHO-LINE)
         (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP))

         (* ;; "Turn off who-line until after the user has greeted")


         (CL:WHEN (WINDOWP *WHO-LINE*)
                (CLOSEW *WHO-LINE*))
         [SETQ POSTGREETFORMS (APPEND POSTGREETFORMS '((INSTALL-WHO-LINE-OPTIONS]
         (FILESLOAD (SYSLOAD)
                UNIXCOMM UNIXCHAT UNIXTELNET)
         (FILESLOAD (SYSLOAD)
                SETDEFAULTPRINTER)
         (FILESLOAD (SYSLOAD)
                LOADPATCHES)
         (\DAYTIME0 \LASTUSERACTION)
         (LISTPUT IDLE.PROFILE 'TIMEOUT 20)
         (for
 TYPE in
 FILEPKTYPES do
 (FILEPKGCHANGES TYPE NIL))
         (SETTOPVAL 'INITIALS NIL)
         (PROMPTPRINT "About to end loadup")
         (PRINTOUT T "About to end loadup" T)

         (* ;; "From SYNCLISPFILES")


         (ENDLOADUP)
         (COND
            ((WINDOWP LOGOW)
             (CLOSEW LOGOW)))
         (DREMOVE (ASSOC 'LOGOW AFTERMAKESYSFORMS)
                AFTERMAKESYSFORMS)
         (push
 AFTERMAKESYSFORMS '(CLRPROMPT)
                '(MEDLEY-INIT-VARS))

         (* ;; "Set up for making the sysout, if we made it this far.")


         (CL:WHEN WRITEFULLSYSOUTFLAG
             (PRINTOUT T "Creating FULL sysout on " MAKESYSFILENAME T)
             (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley " (MEDLEYVERSION)
                              " Full Sysout%")")))
         (DRIBBLE])

(FIXMETA

  [LAMBDA NIL                                                (* ; 

                                                           "Edited 25-Jun-2017 17:12 by rmk:")

    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
           \CURRENTKEYACTION)
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)

(FIXMETA
)

(RPAQQ WRITEFULLSYSOUTFLAG
 T)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
)
(DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY 

(MAKEFULLSYSOUT
)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (853 7655 (LOADFULLFONTS 863 . 3367) (MAKEFULLSYSOUT 3369 . 7344) (FIXMETA 7346 . 7653))
)))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED "22-Feb-2021 16:56:12" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LOADUP-FULL.;2
 8011   

      changes to%:  (FNS MAKEFULLSYSOUT)

      previous date%: " 6-Feb-2021 15:41:34" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LOADUP-FULL.;1)


(PRETTYCOMPRINT LOADUP-FULLCOMS)

(RPAQQ LOADUP-FULLCOMS

       ((COMMANDS "cd" "pwd" "ls")
        (FNS LOADFULLFONTS MAKEFULLSYSOUT FIXMETA)
        (P (FIXMETA))
        (VARS (WRITEFULLSYSOUTFLAG T))
        (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
        (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAKEFULLSYSOUT)))
        (PROP FILETYPE)))

(DEFCOMMAND "cd" (DIR) (/CNDIR DIR))

(DEFCOMMAND "pwd" NIL (DIRECTORYNAME T))

(DEFCOMMAND "ls" (FIRST
 . REST) (DODIR (CONS FIRST REST)))
(DEFINEQ

(LOADFULLFONTS

  [LAMBDA (ROOTDIRECTORY)                                    (* ; 

                                                           "Edited 11-Aug-2020 17:53 by rmk:")


    (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q")


    (PRINTOUT T "Loading FULL fonts..." T)
    (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts")
                                       (PACK* ROOTDIRECTORY "/fonts/altofonts")))
                                                             (* (SETQ INTERPRESSFONTDIRECTORIES

                                                           (CONS (PACK* ROOTDIRECTORY 

                                                           "/fonts/ipfonts"))))

    (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE))
    (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts")))
    (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT)
    (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL)
                (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL))    (* ; 

                  "Don't let the font loader substitute just because a server went catatonic on us")

               (for
 FAMILY in
 '(CLASSIC MODERN TERMINAL)
                  do
 (PRINTOUT T "  Loading " FAMILY " ")
                        [for
 SIZE in
 '(8 10 12)
                           do
 (PRINTOUT T SIZE " ")
                                 (for
 FACE in
 '(MRR BRR MIR)
                                    do
 

                                          (* ;; "No need for Interpress")

                                                             (* (NLSETQ (FONTCREATE FAMILY SIZE 

                                                           FACE NIL (QUOTE INTERPRESS) NIL 0)))

                                          (for
 CSET
                                             in
 '(0 33 34 35 238 239 241)
                                             do
 (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL
                                                                   'DISPLAY NIL CSET]
                        (PRINTOUT T T))
               (PRINTOUT T "  Loading postscript fonts" T)
               (for
 F in
 (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES)
                                                ">c0>*.*")) do
 (PSCFONT.READFONT F))
               (PRINTOUT T "FULL fonts loaded" T])

(MAKEFULLSYSOUT

  [LAMBDA NIL                                                (* ; 

                                                           "Edited  5-Dec-2020 20:07 by larry")

                                                             (* ; 

                                                           "Edited 14-May-2018 15:01 by kaplan")

                                                             (* ; 

                                                           "Edited 22-Feb-2021 16:56 by rmk:")

                                                             (* ; "Edited 17-Apr-2018 08:41 by ")

                                                             (* ; 

                                                           "Edited 21-Apr-2018 07:27 by rmk:")

                                                             (* ; "Edited 23-Feb-94 15:04 by bvm")

    (CLRPROMPT)
    (CNDIR (UNIX-GETENV "LOADUPDIR"))
    (LET ((ROOTDIRECTORY (MEDLEYDIR)))
         (SETQ MAKESYSFILENAME (CONCAT (MEDLEYDIR "loadups")
                                      "xfull35.sysout"))
         (DRIBBLE (PACKFILENAME 'EXTENSION 'DRIBBLE 'BODY MAKESYSFILENAME))

         (* ;; "BKSYSBUF stops page holding ")


         (PRINTOUT T T "Full loadup started at " (DATE)
                " while connected to "
                (DIRECTORYNAME T)
                T T)
         (BKSYSBUF " ")
         (SETQ DEFAULTFILETYPE 'BINARY)                      (* ; 

                                      "These prevent bits from being lost due to lack of knowledge")

         (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST)
                DEFAULTFILETYPELIST)                         (* (SETQ *UPPER-CASE-FILE-NAMES* NIL))

         (SETQ MAKESYSNAME :MEDLEY3.5)
         (push
 DEFAULTFILETYPELIST '(TXT . TEXT)
                '(TEXT . TEXT)
                '(TEX . TEXT)
                '(HTML . TEXT)
                '(HTM . TEXT))
         (MEDLEY-INIT-VARS)
         (SETQ LOADUPDIRECTORIES DIRECTORIES)
         (LOADUP '(POSTSCRIPTSTREAM))                        (* ; " to get PSCFONT.READFONT")

         (LOADFULLFONTS
 (MEDLEYDIR))
         (LISTPUT IDLE.PROFILE 'TIMEOUT 0)
         (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
         (LOADUP '(CHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES GRAPHER SPY
                        WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT UNICODE ISO8859IO
                        HELPSYS DINFO CLIPBOARD MODERNIZE))
         (FILESLOAD (SYSLOAD)
                PRETTYFILEINDEX WHO-LINE)
         (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP))

         (* ;; "Turn off who-line until after the user has greeted")


         (CL:WHEN (WINDOWP *WHO-LINE*)
                (CLOSEW *WHO-LINE*))
         [SETQ POSTGREETFORMS (APPEND POSTGREETFORMS '((INSTALL-WHO-LINE-OPTIONS]
         (FILESLOAD (SYSLOAD)
                UNIXCOMM UNIXCHAT UNIXTELNET)
         (FILESLOAD (SYSLOAD)
                SETDEFAULTPRINTER)
         (FILESLOAD (SYSLOAD)
                LOADPATCHES)
         (\DAYTIME0 \LASTUSERACTION)
         (LISTPUT IDLE.PROFILE 'TIMEOUT 20)
         (for
 TYPE in
 FILEPKTYPES do
 (FILEPKGCHANGES TYPE NIL))
         (SETTOPVAL 'INITIALS NIL)
         (PROMPTPRINT "About to end loadup")
         (PRINTOUT T "About to end loadup" T)

         (* ;; "From SYNCLISPFILES")


         (ENDLOADUP)
         (COND
            ((WINDOWP LOGOW)
             (CLOSEW LOGOW)))
         (DREMOVE (ASSOC 'LOGOW AFTERMAKESYSFORMS)
                AFTERMAKESYSFORMS)
         (push
 AFTERMAKESYSFORMS '(CLRPROMPT)
                '(MEDLEY-INIT-VARS))

         (* ;; "Set up for making the sysout, if we made it this far.")


         (CL:WHEN WRITEFULLSYSOUTFLAG
             (PRINTOUT T "Creating FULL sysout on " MAKESYSFILENAME T)
             (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley " (MEDLEYVERSION)
                              " Full Sysout%")")))
         (DRIBBLE])

(FIXMETA

  [LAMBDA NIL                                                (* ; 

                                                           "Edited 25-Jun-2017 17:12 by rmk:")

    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
           \CURRENTKEYACTION)
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)

(FIXMETA
)

(RPAQQ WRITEFULLSYSOUTFLAG
 T)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
)
(DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY 

(MAKEFULLSYSOUT
)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (885 7750 (LOADFULLFONTS 895 . 3399) (MAKEFULLSYSOUT 3401 . 7439) (FIXMETA 7441 . 7748))
)))
STOP
\ No newline at end of file
diff --git a/sources/LOADUP-FULL.LCOM b/sources/LOADUP-FULL.LCOM
index 4a1a70ad1cd78623f48fdca49ee382d3f03afead..bb519b850198814c361353b02b3c74069d8b7894 100644
GIT binary patch
delta 381
zcmaE$Gf8)XuZWS6u3Ku7u91O}p@N~Am8qGPq0z)dNyX6O)S_a$?8Jhc#5_Bn{N%(O
zyWG^2oYYEVJyW~%%o5$nZy4pQ6_gY#bsY<efcgy#6bvn_3=FM|jg%C4lZsN4^K%O_
zb5c_jQY#9IidC%?d>y@A-9mkQf+K_dLqjIsm#Ig#Tu)C=Ng*Y%1gL>m30cC>#LC3b
z%G5+jlUKvd)5q00$kj2#)kOhS5!C5GtE*jty=!d<x*zD9$?qAZ)D<iY3=I{MGZORC
zQ;QW!@_`Q3aPtdR;6-)r<kgG{hNd8w7@H7p2{4dk7!5abGR+fU_jhp(^7D+^yisU9
FGXP^Ba2Ego

delta 322
zcmbQF`#@)c@8rjf!i=U96D0*R@^e$|auSP*D(y0JGK&lBCMz<@)EjFmC@EO#Iu;b^
z8W|WEC>UB;85mj_8!0Iy6{RNU=N4q<q^2k&XC&sOrxvSPDe&gymt<t-r7L9SDJc1-
zrsSknDj4gTD!7&A<R}DJ7U!3iC@2`}x}_!o%`-Ao(9_dXQb<WG0UDx&EN*0EWel`R
zz(PrrSHsQI$JIH=)iK1?W%5Ht3Gr%|VDDNRtPa*PRxr0TG=sTFfwv?d=qimc$Dm*Z
zAAd)e&;VVxP#+&>f8XHA7Z?>3jjc?~tV}JG6nOC%%4oFNj%l6%m!q?%Ux;gvo1^pQ
I$3p9w0ffC@H~;_u