diff --git a/greetfiles/MAKEINITGREET b/greetfiles/MAKEINITGREET
deleted file mode 100644
index efd13e38..00000000
--- a/greetfiles/MAKEINITGREET
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 5-Dec-2017 15:26:33" 
{DSK}<Volumes>Personal>local>medley3.5>current>MAKEINITGREET.;28 5332   

      changes to%:  (FNS MAKEINITGREET)

      previous date%: "28-Jun-2017 23:52:03" 
{DSK}<Volumes>Personal>local>medley3.5>current>MAKEINITGREET.;27)


(PRETTYCOMPRINT MAKEINITGREETCOMS)

(RPAQQ MAKEINITGREETCOMS [(FNS MAKEINITGREET)
                              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKEINITGREET])
(DEFINEQ

(MAKEINITGREET
  [LAMBDA NIL                                           (* ; "Edited  5-Dec-2017 15:26 by rmk:")

    (* ;; "Make the INIT.DLINIT starting sysout for a new loadup. Derived from MAKEINIT.CM")

    (* ;; "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")

    (* ;; "Start inside $medleydir/sources medley -greet current/MAKEINITGREET    -lisp")

    (* ;; "")

    (CNDIR (CONCAT MEDLEYDIR '/sources))
    (DRIBBLE '../basics/next/MAKEINIT.DRIB)
    (XCL:RESTORE-PROFILE "INTERLISP")
    (DELFILE '../current/INIT.DFASL)
    (AND (INFILEP 'current/INIT.SAVE)
         (RENAMEFILE '../current/INIT.SAVE '../current/INIT.DFASL))
                                                             (* Make sure we have a valid sysout)
    (LET [INITIMAGE INITDLFILE (DATE (CAR (NLSETQ (GETFILEINFO '../basics/FULL.SYSOUT 'ICREATIONDATE]
         [IF [AND NIL DATE (IGREATERP DATE (GETFILEINFO '../basics/Lisp.Sysout 'ICREATIONDATE]
             THEN                                        (* Get new saved sysout)
                   (NLSETQ (PROGN (COPYFILE '..basics/FULL.SYSOUT '{DSK7}LispCore.Sysout;1)

                                  (* ;; "This was to copy all the loadup commands below")

                                  (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 (QUOTE LOAD-LISPCORE-PATCH)))
                                                             (* ; "Doesn't exist")
         (SETQ DIRECTORIES '(../sources ../library ../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 VMEM)
                                                             (* ; "rmk: VMEM has WORDARRAY")
                                                             (* Versions are Lisp Microcode Bcpl)
         (IDLE.SET.OPTION 'TIMEOUT 0)
         (IDLE.SET.OPTION 'SAVEVM 0)
         (PRINTOUT T T T "Starting DORENAME" T T)
         (DORENAME 'I)
         (PRINTOUT T T T T "DORENAME finished, starting MAKEINIT" T)
         [SETQ INITIMAGE (MAKEINIT '(39424 5682 11008)
                                NIL
                                '../basics/next/INIT.SYSOUT
                                '(../sources/ ../internal/library/ ../library/]
         (PRINTOUT T T T T "MAKEINIT finished, starting DLFIXINIT" T)
         (SETQ INITDLFILE (DLFIXINIT INITIMAGE '../basics/next/INIT.DLINIT 
                                 '../sunloadup/LispDlion.db 300))
         (PRINTOUT T T "Initial sysout saved to " INITDLFILE T)
         (COPYFILE '../sunloadup/XREM-NOETHER.CM (CONCAT '{DSK}/Users/ (USERNAME)
                                                        '/REM.CM))
         (DRIBBLE)                                           (* ; "Why logout? (LOGOUT T)")
         INITDLFILE])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(MAKEINITGREET)
)
(PUTPROPS MAKEINITGREET COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (503 5211 (MAKEINITGREET 513 . 5209)))))
STOP
\ No newline at end of file
diff --git a/greetfiles/MAKEINITGREET.LCOM b/greetfiles/MAKEINITGREET.LCOM
deleted file mode 100644
index 4ba1a611..00000000
Binary files a/greetfiles/MAKEINITGREET.LCOM and /dev/null differ
diff --git a/greetfiles/MAKEINITGREET.LCOM.~27~ b/greetfiles/MAKEINITGREET.LCOM.~27~
deleted file mode 100644
index 4ba1a611..00000000
Binary files a/greetfiles/MAKEINITGREET.LCOM.~27~ and /dev/null differ
diff --git a/greetfiles/MAKEINITGREET.~1~ b/greetfiles/MAKEINITGREET.~1~
deleted file mode 100644
index 1c5697f6..00000000
--- a/greetfiles/MAKEINITGREET.~1~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "24-Jun-2017 19:27:26" 
{DSK}<Volumes>Personal>local>medley3.5>current>MAKEINITGREET.;1 4254   

      changes to%:  (VARS MAKEINITGREETCOMS)
                    (FNS MAKEINITGREET))


(PRETTYCOMPRINT MAKEINITGREETCOMS)

(RPAQQ MAKEINITGREETCOMS ((FNS MAKEINITGREET)))
(DEFINEQ

(MAKEINITGREET
  [LAMBDA NIL                                           (* ; "Edited 24-Jun-2017 19:26 by rmk:")
    ((
      (* ;; "Make the INIT.DLINIT starting sysout for a new loadup. Derived from MAKEINIT.CM")

      (* ;; "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")

      )

     (* ;; "Start inside $medleydir medley -greet current/MAKEINITGREET    -lisp")

     (* ;; "")

     (XCL:RESTORE-PROFILE "INTERLISP")
     (DELFILE 'current/INIT.DFASL)
     (AND (INFILEP 'current/INIT.SAVE)
          (RENAMEFILE 'current/INIT.SAVE current/INIT.DFASL))
     (DIRECTORY 'current/INIT.DLINIT;* '(DELETE))            (* Make sure we have a valid sysout)
     [LET [(DATE (CAR (NLSETQ (GETFILEINFO basics/FULL.SYSOUT 'ICREATIONDATE]
          (IF [AND NIL DATE (IGREATERP DATE (GETFILEINFO 'basics/Lisp.Sysout 'ICREATIONDATE]
              THEN                                       (* Get new saved sysout)
                    (NLSETQ (PROGN (COPYFILE 'basics/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 (QUOTE LOAD-LISPCORE-PATCH)))
                                                             (* ; "Doesn't exist")
     (SETQ DIRECTORIES '(sources/ /library 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})                                  (* ; "CNDIR doesn't know about {CORE}")
            (IDLE.SET.OPTION 'TIMEOUT 0)
            (IDLE.SET.OPTION 'SAVEVM 0)
            (DORENAME 'I)
            (DLFIXINIT (MAKEINIT '(39424 5682 11008)
                              NIL NIL '(sources/ /internal/library/ library/)
                              'INIT.DLINIT LispDLion.db 300)
                   (LOGOUT T)))
     NIL])
)
(PUTPROPS MAKEINITGREET COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (355 4189 (MAKEINITGREET 365 . 4187)))))
STOP
\ No newline at end of file
diff --git a/greetfiles/MAKEINITGREET.~27~ b/greetfiles/MAKEINITGREET.~27~
deleted file mode 100644
index aad40f96..00000000
--- a/greetfiles/MAKEINITGREET.~27~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "28-Jun-2017 23:52:03" 
{DSK}<Volumes>Personal>local>medley3.5>current>MAKEINITGREET.;27 5323   

      changes to%:  (FNS MAKEINITGREET)

      previous date%: "28-Jun-2017 23:51:37" 
{DSK}<Volumes>Personal>local>medley3.5>current>MAKEINITGREET.;26)


(PRETTYCOMPRINT MAKEINITGREETCOMS)

(RPAQQ MAKEINITGREETCOMS [(FNS MAKEINITGREET)
                              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKEINITGREET])
(DEFINEQ

(MAKEINITGREET
  [LAMBDA NIL                                           (* ; "Edited 28-Jun-2017 23:52 by rmk:")

    (* ;; "Make the INIT.DLINIT starting sysout for a new loadup. Derived from MAKEINIT.CM")

    (* ;; "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")

    (* ;; "Start inside $medleydir/sources medley -greet current/MAKEINITGREET    -lisp")

    (* ;; "")

    (CNDIR (CONCAT MEDLEYDIR '/sources))
    (DRIBBLE '../basics/next/MAKEINIT.DRIB)
    (XCL:RESTORE-PROFILE "INTERLISP")
    (DELFILE '../current/INIT.DFASL)
    (AND (INFILEP 'current/INIT.SAVE)
         (RENAMEFILE '../current/INIT.SAVE '../current/INIT.DFASL))
                                                             (* Make sure we have a valid sysout)
    (LET [INITIMAGE INITDLFILE (DATE (CAR (NLSETQ (GETFILEINFO '../basics/FULL.SYSOUT 'ICREATIONDATE]
         [IF [AND NIL DATE (IGREATERP DATE (GETFILEINFO '../basics/Lisp.Sysout 'ICREATIONDATE]
             THEN                                        (* Get new saved sysout)
                   (NLSETQ (PROGN (COPYFILE '..basics/FULL.SYSOUT '{DSK7}LispCore.Sysout;1)

                                  (* ;; "This was to copy all the loadup commands below")

                                  (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 (QUOTE LOAD-LISPCORE-PATCH)))
                                                             (* ; "Doesn't exist")
         (SETQ DIRECTORIES '(../sources ../library ../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 VMEM)
                                                             (* ; "rmk: VMEM has WORDARRAY")
                                                             (* Versions are Lisp Microcode Bcpl)
         (IDLE.SET.OPTION 'TIMEOUT 0)
         (IDLE.SET.OPTION 'SAVEVM 0)
         (PRINTOUT T T T "Starting DORENAME" T T)
         (DORENAME 'I)
         (PRINTOUT T T T T "DORENAME finished, starting MAKEINIT" T)
         [SETQ INITIMAGE (MAKEINIT '(39424 5682 11008)
                                NIL
                                '{CORE}INIT.SYSOUT
                                '(../sources/ ../internal/library/ ../library/]
         (PRINTOUT T T T T "MAKEINIT finished, starting DLFIXINIT" T)
         (SETQ INITDLFILE (DLFIXINIT INITIMAGE '../basics/next/INIT.DLINIT 
                                 '../sunloadup/LispDlion.db 300))
         (PRINTOUT T T "Initial sysout saved to " INITDLFILE T)
         (COPYFILE '../sunloadup/XREM-NOETHER.CM (CONCAT '{DSK}/Users/ (USERNAME)
                                                        '/REM.CM))
         (DRIBBLE)                                           (* ; "Why logout? (LOGOUT T)")
         INITDLFILE])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(MAKEINITGREET)
)
(PUTPROPS MAKEINITGREET COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (503 5202 (MAKEINITGREET 513 . 5200)))))
STOP
\ No newline at end of file
diff --git a/greetfiles/MAKEINITGREET.~28~ b/greetfiles/MAKEINITGREET.~28~
deleted file mode 100644
index efd13e38..00000000
--- a/greetfiles/MAKEINITGREET.~28~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 5-Dec-2017 15:26:33" 
{DSK}<Volumes>Personal>local>medley3.5>current>MAKEINITGREET.;28 5332   

      changes to%:  (FNS MAKEINITGREET)

      previous date%: "28-Jun-2017 23:52:03" 
{DSK}<Volumes>Personal>local>medley3.5>current>MAKEINITGREET.;27)


(PRETTYCOMPRINT MAKEINITGREETCOMS)

(RPAQQ MAKEINITGREETCOMS [(FNS MAKEINITGREET)
                              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKEINITGREET])
(DEFINEQ

(MAKEINITGREET
  [LAMBDA NIL                                           (* ; "Edited  5-Dec-2017 15:26 by rmk:")

    (* ;; "Make the INIT.DLINIT starting sysout for a new loadup. Derived from MAKEINIT.CM")

    (* ;; "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")

    (* ;; "Start inside $medleydir/sources medley -greet current/MAKEINITGREET    -lisp")

    (* ;; "")

    (CNDIR (CONCAT MEDLEYDIR '/sources))
    (DRIBBLE '../basics/next/MAKEINIT.DRIB)
    (XCL:RESTORE-PROFILE "INTERLISP")
    (DELFILE '../current/INIT.DFASL)
    (AND (INFILEP 'current/INIT.SAVE)
         (RENAMEFILE '../current/INIT.SAVE '../current/INIT.DFASL))
                                                             (* Make sure we have a valid sysout)
    (LET [INITIMAGE INITDLFILE (DATE (CAR (NLSETQ (GETFILEINFO '../basics/FULL.SYSOUT 'ICREATIONDATE]
         [IF [AND NIL DATE (IGREATERP DATE (GETFILEINFO '../basics/Lisp.Sysout 'ICREATIONDATE]
             THEN                                        (* Get new saved sysout)
                   (NLSETQ (PROGN (COPYFILE '..basics/FULL.SYSOUT '{DSK7}LispCore.Sysout;1)

                                  (* ;; "This was to copy all the loadup commands below")

                                  (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 (QUOTE LOAD-LISPCORE-PATCH)))
                                                             (* ; "Doesn't exist")
         (SETQ DIRECTORIES '(../sources ../library ../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 VMEM)
                                                             (* ; "rmk: VMEM has WORDARRAY")
                                                             (* Versions are Lisp Microcode Bcpl)
         (IDLE.SET.OPTION 'TIMEOUT 0)
         (IDLE.SET.OPTION 'SAVEVM 0)
         (PRINTOUT T T T "Starting DORENAME" T T)
         (DORENAME 'I)
         (PRINTOUT T T T T "DORENAME finished, starting MAKEINIT" T)
         [SETQ INITIMAGE (MAKEINIT '(39424 5682 11008)
                                NIL
                                '../basics/next/INIT.SYSOUT
                                '(../sources/ ../internal/library/ ../library/]
         (PRINTOUT T T T T "MAKEINIT finished, starting DLFIXINIT" T)
         (SETQ INITDLFILE (DLFIXINIT INITIMAGE '../basics/next/INIT.DLINIT 
                                 '../sunloadup/LispDlion.db 300))
         (PRINTOUT T T "Initial sysout saved to " INITDLFILE T)
         (COPYFILE '../sunloadup/XREM-NOETHER.CM (CONCAT '{DSK}/Users/ (USERNAME)
                                                        '/REM.CM))
         (DRIBBLE)                                           (* ; "Why logout? (LOGOUT T)")
         INITDLFILE])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(MAKEINITGREET)
)
(PUTPROPS MAKEINITGREET COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (503 5211 (MAKEINITGREET 513 . 5209)))))
STOP
\ No newline at end of file
diff --git a/sources/FILEPKG.LCOM.~10~ b/sources/FILEPKG.LCOM.~10~
deleted file mode 100644
index 5a12cc74..00000000
Binary files a/sources/FILEPKG.LCOM.~10~ and /dev/null differ
diff --git a/sources/FILEPKG.LCOM.~11~ b/sources/FILEPKG.LCOM.~11~
deleted file mode 100644
index 2dcdd489..00000000
Binary files a/sources/FILEPKG.LCOM.~11~ and /dev/null differ
diff --git a/sources/FILEPKG.LCOM.~12~ b/sources/FILEPKG.LCOM.~12~
deleted file mode 100644
index 4ec81efe..00000000
Binary files a/sources/FILEPKG.LCOM.~12~ and /dev/null differ
diff --git a/sources/FILEPKG.LCOM.~13~ b/sources/FILEPKG.LCOM.~13~
deleted file mode 100644
index c3d5a0d8..00000000
Binary files a/sources/FILEPKG.LCOM.~13~ and /dev/null differ
diff --git a/sources/FILEPKG.LCOM.~7~ b/sources/FILEPKG.LCOM.~7~
deleted file mode 100644
index 5faf6523..00000000
Binary files a/sources/FILEPKG.LCOM.~7~ and /dev/null differ
diff --git a/sources/FILEPKG.LCOM.~8~ b/sources/FILEPKG.LCOM.~8~
deleted file mode 100644
index 5ab3e83b..00000000
Binary files a/sources/FILEPKG.LCOM.~8~ and /dev/null differ
diff --git a/sources/FILEPKG.LCOM.~9~ b/sources/FILEPKG.LCOM.~9~
deleted file mode 100644
index db587672..00000000
Binary files a/sources/FILEPKG.LCOM.~9~ and /dev/null differ
diff --git a/sources/FILEPKG.~10~ b/sources/FILEPKG.~10~
deleted file mode 100644
index b849fd17..00000000
--- a/sources/FILEPKG.~10~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "10-Aug-2020 21:19:02" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;10 284784 

      changes to%:  (VARS FILEPKGCOMS)
                    (FNS ADDTOFILES?)

      previous date%: " 8-Aug-2020 17:33:31" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;9)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020 by Venue & Xerox Corporation.  All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")

(PRETTYCOMPRINT FILEPKGCOMS)

(RPAQQ FILEPKGCOMS
       [(COMS                                                (* ; 
            "standard records for accessing file  package type/command parts.  Exported for PRETTY")
              (VARS FILEPKGTYPEPROPS)
              (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
              (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
              (INITRECORDS * FILEPKGRECORDS))
        [DECLARE%: EVAL@COMPILE DOCOPY 

               (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.")

               (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES 
                                       PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS
                                       PRETTYFLG))
                  (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES 
                                       NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS]
        (INITVARS (MSDATABASELST))
        [COMS 
              (* ;; "making, adding, listing, compiling files")

              (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES 
                   FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE
                   ADDFILE0 LISTFILES)
              (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
                     (FILELST)
                     (LOADEDFILELST)
                     (NOTLISTEDFILES)
                     (NOTCOMPILEDFILES)
                     (MAKEFILEFORMS)
                     (NILCOMS))
              (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% 
                              F ST STF (REC . RC)
                              (BREC . RC)
                              (TC . C)
                              (BC . C)
                              (TCOMPL . C)
                              (BCOMPL . C)))
              (INITVARS (MAKEFILEREMAKEFLG T)
                     (CLEANUPOPTIONS '(RC]
        (COMS 
              (* ;; "scanning file coms")

              (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS 
                   FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM
                   INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                   IFCDECLARE INFILEPAIRS INFILECOMSMACRO))
        (COMS 
              (* ;; "adding to a file")

              (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM 
                   ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM)
              (INITVARS (DEFAULTCOMHASFILEFLG))
              (ADDVARS (MARKASCHANGEDFNS))
              (FNS MERGEINSERT MERGEINSERT1)
              
              (* ;; "RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file")

              (VARS [ADDTOFILEKEYLST `(("[" "" EXPLAINSTRING 
                                           "[ -- prettyprint the item to terminal and then ask again"
                                            NOECHOFLG T)
                                       (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG
                                          T)
                                       (,(CHARACTER (CHARCODE LF))
                                        "" EXPLAINSTRING "{line-feed} - same as previous response" 
                                        NOECHOFLG T)
                                       (" " ,(CONCATCODES (LIST (CHARCODE SPACE)
                                                                (CHARCODE EOL)))
                                            EXPLAINSTRING "{space} - no action" NOECHOFLG T)
                                       ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
                                            EXPLAINSTRING
                                            ,(CONCAT "] - nowhere, item is marked as a dummy"
                                                    (CHARACTER (CHARCODE EOL)))
                                            NOECHOFLG T)
                                       ["(" "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
                                            (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE))
                                                                 ,(CHARACTER (CHARCODE EOL]
                                                RETURN
                                                (CDR ANSWER]
                                       '(@ "Near: " EXPLAINSTRING 
                                           "@ other-item   -- put the item near the other item" 
                                           NOECHOFLG T KEYLST (( "" CONFIRMFLG (%
)
                                                                  RETURN ANSWER)))
                                       [,(CHARACTER (CHARCODE CR))
                                        "" RETURN ,(CHARACTER (CHARCODE SPACE]
                                       ("" "File name: " EXPLAINSTRING "a file name" KEYLST (]
                    (LASTFILE)))
        (COMS 
              (* ;; "deleting an item from a file")

              (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE)
              (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
                 (MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
              (ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
        [COMS                                                (* ; 
                      "functions for doing things and marking them changed and auxiliary functions")
              (FNS SAVEPUT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
                                                     (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
              (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
              (ADDVARS (LISPXFNS (PUT . SAVEPUT)
                              (PUTPROP . SAVEPUT]
        (COMS                                                (* ; 
                                                  "sub-functions for file package commands & types")
              (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED 
                   MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS 
                   PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS 
                   FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS 
                   FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED)
              (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO)
                     (SYSPROPS PROPTYPE))
              (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT 
                    FILETYPE)
              (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS 
                    LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS 
                    PRETTYPRINTYPEMACROS USERMACROS))
        (COMS                                                (* ; 
                    "Define the commands below AFTER the various properties have been established.")
              (USERMACROS M))
        (COMS                                                (* ; "GETDEF methods")
              (FNS RENAME CHANGECALLERS)
              (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
                   GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF 
                   DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
              (INITVARS (WHEREIS.HASH)))
                                                             (* ; "Must come after PUTDEF")
        (FNS FIXEDITDATE EDITDATE?)
                                                             (* ; 
                                  "Edit date support for all kinds of definers (from PARC 6/10/92)")
        [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
              (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
        (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
        (COMS 
              (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")

              (FNS FILEPKGCOM FILEPKGTYPE)
              (PROP ARGNAMES FILEPKGCOM)
              (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
                     (FILEPKGTYPES FILEPKGCOMS))
              (FILEPKGCOMS FILEPKGCOMS)
              (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS
                     INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS
                     OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS))
        (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS)
                        (VARIABLES VARS CONSTANTS)))
        (INITVARS (SAVEDDEFS))
        (COMS                                                (* ; "EDITCALLERS")
              (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
              (FNS SEPRCASE)
              [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL]
              (INITVARS (SEPRCASEARRAYS)
                     (CLISPCASEARRAYS))
              (P (MOVD? 'INFILEP 'FINDFILE)
                                                             (* ; "or else from SPELLFILE"))
              (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
                             (NOLINKFNS LOADFROM)))
              (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS))
        (COMS                                                (* ; "EXPORT")
              (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS)
              (FILEPKGCOMS EXPORT)
              [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
                     (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"]
              (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM))
        (COMS                                                (* ; "for GAINSPACE")
              (FNS CLEARFILEPKG)
              [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                              ((Y "es")
                                               (N "o")
                                               (E . "verything")
                                               (F "ilemaps only
"]
              (GLOBALVARS SMASHPROPSLST1))
        (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT 
               DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 
               I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS 
               MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS 
               SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS)
        (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
                       (SPECVARS COMSNAME))
               (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
                      (NOLINKFNS . T)
                      (SPECVARS COMSNAME)
                      (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
               (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL 
                      INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                      IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
                      INFILECOMSPROP)
               (NIL MAKEFILE (LOCALVARS . T)
                    (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
               (ADDFILE ADDFILE ADDFILE0)
               (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
               (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
                    COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES 
                    EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM 
                    FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL 
                    LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS 
                    MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE 
                    POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
                    SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED 
                    UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS 
                                                 COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
                    (LOCALVARS . T))
               (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
               (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
                      GETDEFSAVED (RETFNS GETDEFCOM)
                      (NOLINKFNS . T)
                      (GLOBALVARS NOT-FOUNDTAG)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS 
                               MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP 
                               FILEPKGCOMPROPS PRETTYDEFMACROS)
                      (NLAML)
                      (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES])



(* ; "standard records for accessing file  package type/command parts.  Exported for PRETTY")


(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF CANFILEDEF FILEGETDEF))
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(DECLARE%: EVAL@COMPILE

(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
                                               (T (/REMPROP DATUM 'PRETTYTYPE]
                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
                                  (STANDARD [COND
                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
                                                                (OR (LISTP (GETTOPVAL 
                                                                                  'PRETTYDEFMACROS))
                                                                    (SETTOPVAL 'PRETTYDEFMACROS
                                                                           (LIST (LIST DATUM]
                                               (T (SETTOPVAL 'PRETTYDEFMACROS
                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
                                                                                'PRETTYDEFMACROS))
                                                                (GETTOPVAL 'PRETTYDEFMACROS]
                                         UNDOABLE
                                         (COND
                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
                                                                        (LIST (LIST DATUM]
                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
                                                                                   'PRETTYDEFMACROS))
                                                             (GETTOPVAL 'PRETTYDEFMACROS]
                                                             (* Not an atom record cause want 
                                                           REMPROP on NILs.)
                                                             (* NOTE%: PRETTCOM on PRETTY has 
                                                           open-coded access to the MACRO 
                                                           property.)
                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
                                       FILEPKGCONTENTS)))

(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
                                                           )
                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
                                                                              DATUM)))
                                                           (STANDARD (SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                      DATUM NEWVALUE)
                                                                                     )
                                                                            NEWVALUE)
                                                                  UNDOABLE
                                                                  (/SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                    DATUM NEWVALUE))
                                                                         NEWVALUE)))
                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
                                                                             DATUM)))
                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
                                                                               DATUM NEWVALUE))
                                                                       NEWVALUE)))
                                                    (ALLFIELDS NIL (/SETTOPVAL
                                                                    'PRETTYTYPELST
                                                                    (REMOVE (SEARCHPRETTYTYPELST
                                                                             DATUM)
                                                                           (GETTOPVAL 'PRETTYTYPELST]
                                                             (* NOTE%: PRETTYCOM on PRETTY has 
                                                           open-coded access to GETDEF property)
                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                                                                   (PUT X
                                                                                        'PROPTYPE
                                                                                        'FILEPKGCOMS]
                                         (ADDTOVAR PRETTYTYPELST ))))

(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
                                                    UNDOABLE
                                                    (/PUTPROP DATUM 'FILE NEWVALUE])

(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))

(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
)

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
)

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(SEARCHPRETTYTYPELST
  [LAMBDA (TYPE FLG)                                     (* rmk%: " 3-JAN-82 22:55")
                                                             (* ; 
                                                           "access functions used by the records")
    (AND (LITATOM TYPE)
         (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X)
                                                               TYPE))
             (COND
                (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE
                                                                             'LST)
                                                                      TYPE NIL))
                                                      (GETTOPVAL 'PRETTYTYPELST]
                     (OR (LISTP (GETTOPVAL (CAR FLG)))
                         (/SETTOPVAL (CAR FLG)
                                NIL))
                     FLG])

(PRETTYDEFMACROS
  [NLAMBDA ARGS                                          (* lmm " 5-SEP-78 16:16")
                                                             (* ; 
                                                 "included so that old files will continue to load")
    (for X in ARGS collect (FILEPKGCOM (CAR X)
                                              'MACRO
                                              (CDR X])

(FILEPKGCOMPROPS
  [NLAMBDA PROPS
    (MAPC PROPS (FUNCTION (LAMBDA (Y)
                            (OR (MEMB Y SYSPROPS)
                                (SETQ SYSPROPS (CONS Y SYSPROPS)))
                            (PUT Y 'PROPTYPE 'FILEPKGCOMS])
)

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS 
                     *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG))

(CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS 
                     CLEANUPOPTIONS))
)

(RPAQ? MSDATABASELST )



(* ;; "making, adding, listing, compiling files")

(DEFINEQ

(CLEANUP
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (PROG (TEM1 TEM2 OPTIONS)
          (COND
             ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
              (SETQ OPTIONS (CAR FILES))
              (SETQ FILES (CDR FILES)))
             (T (SETQ OPTIONS CLEANUPOPTIONS)))
          (RETURN (APPEND (MAKEFILES OPTIONS FILES)
                         (COND
                            ((NOT (MEMB 'LIST OPTIONS))
                             NIL)
                            ((NULL FILES)
                             (LISTFILES))
                            ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES))
                                                             (* ; 
            "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.")
                             (APPLY 'LISTFILES TEM1)))
                         (COND
                            [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS]
                            ((NULL FILES)
                             (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES)
                                    (CDR TEM1))
                             TEM2)
                            ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES))
                             (COMPILEFILES0 TEM2 (CDR TEM1))
                             TEM2])

(COMPILEFILES
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (COND
       ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
        (COMPILEFILES0 (CDR FILES)
               (CAR FILES)))
       (T (COMPILEFILES0 FILES])

(COMPILEFILES0
  [LAMBDA (FILES OPTIONS)                                (* rmk%: "19-FEB-83 21:59")
    (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES)
       first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS))
                                (C (SETQ RCFLG NIL)
                                   (CDR OPTIONS))
                                (RC (CDR OPTIONS))
                                OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X)
                                                                           70 FILELST NIL X)
                                                                    (CAR X))
                                                        RCFLG OPTS X])

(CONTINUEDIT
  [LAMBDA (FILE)                                         (* bvm%: "30-Aug-86 15:09")
    (PROG (STREAM FL TEM FC ENV)
          (RESETLST
              [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT]
              (SETQ FILE (FULLNAME STREAM))
              (SETFILEPTR STREAM 0)
              (CL:MULTIPLE-VALUE-SETQ (ENV FC)
                     (\PARSE-FILE-HEADER STREAM 'RETURN)))
          (COND
             ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE]
              (LOADFROM FILE)                                (* ; 
                                                           "also calls addfile to notice the file.")
              ))
          (/replace FILECHANGES of FL with (FILECHANGES FC))
          [/replace FILEDATES of FL with
                                            (LIST (create FILEDATEPAIR
                                                         FILEDATE _ (CADR FC)
                                                         DATEFILENAME _ FILE)
                                                  (create FILEDATEPAIR
                                                         FILEDATE _
                                                         [CAR (SETQ TEM (CDR (MEMB 'date%: FC]
                                                         DATEFILENAME _ (CADR TEM]
          (RETURN FILE])

(MAKEFILE
  [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)           (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL;  LIST means list the FILE;  RC means RECOMPILE, C means COMPILEL;  --- for C AND RC assume ST unless next option is F.")

    (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS]
                           PRETTYFLG))
           (*PRINT-BASE* (if (EQ *PRINT-BASE* 8)
                             then 8
                           else                          (* ; "make sure radix is either 8 or 10, because all others don't read in like they print.  Maybe obsolete now with makefile environments")
                                 10))
           FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
          (DECLARE (CL:SPECIAL PRETTYFLG))
          (SETQ FILE (CAR Z))                                (* ; 
                                               "Necessary because FILE might have been misspelled.")
          (SETQ ROOTNAME (CADR Z))                           (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.")
          (SETQ FILEPROP (CDDR Z))
          (UPDATEFILES)                                  (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.")
          (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
          (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
          (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE))
      LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
                       (NULL FILEDATES))
              then                                       (* ; 
                   "File has never been loaded and never dumped i.e. user just set up COMS in core")
            elseif [OR (EQMEMB 'NEW OPTIONS)
                           (AND (NULL MAKEFILEREMAKEFLG)
                                (NOT (MEMB 'REMAKE OPTIONS]
              then (COND
                          ((AND (fetch LOADTYPE of FILEPROP)
                                (NEQ T (fetch LOADTYPE of FILEPROP)))
                           (LISPXPRIN2 FILE T T)
                           (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
                                           (LOADCOMP 
                                                  "the file was loaded for compilation purposes only")
                                           ((compiled Compiled COMPILED) 
                                                " -- only the compiled file has been loaded
")
                                           ((loadfns LOADFNS) 
                                                " -- only some of its symbolics have been loaded
")
                                           (SHOULDNT))
                                  T)
                           (COND
                              ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ")
                                    'Y)                      (* ; 
            "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.")
                               (GO OUT)))
                           (/replace LOADTYPE of FILEPROP with NIL)))
                    (SETQ SOURCEFILE NIL)
                    (SETQ REPRINTFNS NIL)
            elseif SOURCEFILE
              then                                       (* ; "source file given")
            elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T))
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
                                          (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE
                                                                              (fetch DATEFILENAME
                                                                                 of (CAR 
                                                                                            FILEDATES
                                                                                             ]
                                               (INFILEP SOURCEFILE)
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
              then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
                    (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
            elseif [AND (CDR FILEDATES)
                            [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
                            (EQUAL (FILEDATE SOURCEFILE)
                                   (fetch FILEDATE of (CADR FILEDATES]
              then 

                    (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.")

                    (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
                                         (fetch FILECHANGES of ROOTNAME)))
                    (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
            else (LISPXPRIN1 
                            '"can't find either the previous version or the original version of 
" T)
                  (LISPXPRIN2 FILE T T)
                  (LISPXPRIN1 '", so it will have to be written anew
" T)
                  (SETQ SOURCEFILE NIL)
                  (SETQ REPRINTFNS NIL)
                  (push OPTIONS 'NEW)
                  (SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
                  (GO LP0))
          (COND
             ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
                                          (LOADCOMP          (* ; 
                                                   "only loaded via LOADCOMP.  Need to do LOADFROM")
                                                    (LIST 'N SOURCEFILE "was loaded with LOADCOMP"
                                                          '- "LOADFROM it to obtain VARS/COMS"))
                                          (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%:
                                                                (fetch COMSNAME of FILEPROP))
                                                         (LIST 'Y "only compiled version of" ROOTNAME
                                                               
                                        "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions"
                                                               )))
                                          ((compiled loadfns) 
                                               (LIST 'N "Only some functions from" SOURCEFILE 
                                             "loaded via LOADFNS. Load all other expressions from it"
                                                     ))
                                          NIL)))
              (SELECTQ [ASKUSER DWIMWAIT (CAR Z)
                              (CDR Z)
                              '((Y "es
")
                                (N "o
")
                                (A "bort MAKEFILE
"]
                  (Y (SELECTQ (fetch LOADTYPE of FILEPROP)
                         (LOADCOMP                           (* ; 
                               "file was never actually loaded, just loadcomped.  thus no filecoms")
                                   (LOADFROM SOURCEFILE))
                         (Compiled 

                                 (* ;; "This is going to be a remake.  If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.")

                                   (LOADVARS 'DONTCOPY SOURCEFILE)
                                   (/replace LOADTYPE of FILEPROP with 'COMPILED)
                                                             (* ; "So wont have to be done again.")

                                 (* ;; "These are the only DECLARE:'s that are not also on the compiled file.  Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE:  Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)")

                                   )
                         ((loadfns compiled) 

                                 (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.")

                              (LOADVARS T SOURCEFILE))
                         NIL))
                  (A (GO OUT))
                  NIL)))
          (RESETLST
              [COND
                 ((MEMB 'NOCLISP OPTIONS)
                  (RESETSAVE PRETTYTRANFLG T))
                 ((MEMB 'CLISP%  OPTIONS)
                  (RESETSAVE PRETTYTRANFLG 'BOTH]
              (RESETSAVE %#UNDOSAVES)
              [COND
                 ((OR (MEMB 'CLISPIFY OPTIONS)
                      (MEMB 'CLISP OPTIONS))
                  (RESETSAVE CLISPIFYPRETTYFLG T))
                 ((OR (EQ FILETYPE 'CLISP)
                      (MEMB 'CLISP (LISTP FILETYPE)))
                  (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES]
              (for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
              (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
                                REPRINTFNS SOURCEFILE CHANGES)))
          (SETQ LASTFILE ROOTNAME)
          (/replace TOBEDUMPED of FILEPROP with NIL)
          (COND
             ((NOT (EQMEMB 'DON'TLIST FILETYPE))
              (pushnew NOTLISTEDFILES ROOTNAME)))
          (COND
             ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE))
              (pushnew NOTCOMPILEDFILES ROOTNAME)))
          [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL))
                                                 (SELECTQ OPT
                                                     (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                              (MAKEFILE1 FILE T (CDR TAIL))))
                                                     (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                             (MAKEFILE1 FILE NIL (CDR TAIL))))
                                                     (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
                                                                (APPLY 'LISTFILES (LIST FILE))))
                                                     (COND
                                                        ((MEMB OPT MAKEFILEOPTIONS))
                                                        ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL 
                                                                OPTIONS)
                                                         (GO $$LP))
                                                        (T (ERROR "Unrecognized MAKEFILE option" OPT]
          (RETURN FILE)
      OUT (RETURN (LIST FILE "-- MAKEFILE not performed."])

(FILECHANGES
  [LAMBDA (FILE TYPE)                                    (* bvm%: "30-Aug-86 15:08")

    (* ;; "If FILE is a list, it is assumed to be a file-created expressions;  otherwise, the filecreated expression is read from FILE.  If TYPE, returns the list of changed items of that type from the changes expression.  If TYPE=NIL, returns the whole list of typed change-lists")

    (PROG ([FCEXPR (OR (LISTP FILE)
                       (AND FILE (RESETLST
                                     (LET (OLDPTR STREAM)
                                          [if (SETQ STREAM (OPENP FILE 'INPUT))
                                              then (SETQ OLDPTR (GETFILEPTR STREAM))
                                                    (SETFILEPTR STREAM 0)
                                            else (RESETSAVE NIL (LIST 'CLOSEF
                                                                          (SETQ STREAM
                                                                           (OPENSTREAM FILE
                                                                                  'INPUT]
                                          (CL:MULTIPLE-VALUE-BIND (ENV FC)
                                                 (\PARSE-FILE-HEADER STREAM 'RETURN)
                                                 (if OLDPTR
                                                     then (SETFILEPTR STREAM OLDPTR))
                                                 FC)))]
           FNS CHANGES)
          (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR)))
                               (MEMB 'previous CHANGES)))
          [if (AND TYPE (NEQ TYPE 'FNS))
              then (RETURN (CDR (ASSOC TYPE CHANGES]
          (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM)))     (* ; 
                         "Old style changes expression listed FNS by name and other things by type")
          (RETURN (if TYPE
                      then                               (* ; "TYPE=FNS cause of test above.")
                            (NCONC FNS (CDR (ASSOC 'FNS CHANGES)))
                    elseif FNS
                      then (CONS (CONS 'FNS FNS)
                                     (SUBSET CHANGES (FUNCTION LISTP)))
                    else CHANGES])

(FILEPKG.MERGECHANGES
  [LAMBDA (C1 C2)                                        (* rmk%: "24-MAY-82 23:09")

    (* ;; "Merges 2 changes lists into a single one.  Treat LITATOM's as FNS, to accomodate old-style format on files.")

    (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND
                                                                                         E1)))
       in C2 do [COND
                           ((SETQ TEMP (ASSOC (CAR E2)
                                              VAL))
                            (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP))
                                           collect X)))
                           (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL])

(FILEPKG.CHANGEDFNS
  [LAMBDA (CHANGES)                                      (* rmk%: "20-MAY-82 22:00")

    (* ;; "Returns list of function names from a file-changes list.  Interprets old format (functions are atoms) and new format (with explicit type headers)")

    (CDR (ASSOC 'FNS CHANGES])

(MAKEFILE1
  [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES)            (* ; "Edited 29-Aug-89 11:46 by bvm")
    (PROG* ((ROOTNAME (ROOTFILENAME FILE))
            (COMPILER (COMPILE-FILE? ROOTNAME))
            GROUP)
           (COND
              ((AND (OR (EQ COMPILER 'BCOMPL)
                        (EQ COMPILER 'TCOMPL))
                    (NOT (FILEFNSLST ROOTNAME)))         (* ; 
                 "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.")
               (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
               (RETURN NIL)))
           (COND
              ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP))
                  suchthat (AND (NEQ X ROOTNAME)
                                    (OR (fetch TOBEDUMPED of (fetch FILEPROP of
                                                                                         X))
                                        (MEMB X OTHERFILES]

               (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled.  Wait.")

               (RETURN)))
           (LISPXPRIN1 '"
compiling " T)
           (LISPXPRINT (OR GROUP FILE)
                  T T)
           (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS)
                                                'ST)
                                            (EQ (CAR OPTIONS)
                                                'STF]
                             (FORGET-EXPRS? (EQ (CAR OPTIONS)
                                                'STF]
                            (SELECTQ COMPILER
                                ((FAKE-COMPILE-FILE)         (* ; 
                                               "The old CommonLispy interface to the ByteCompiler.")
                                     (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS
                                            (AND REDEFINE? (NOT FORGET-EXPRS?))))
                                ((CL:COMPILE-FILE)           (* ; "The new, improved (?) compiler")
                                     (CL:COMPILE-FILE FILE :LOAD (COND
                                                                    ((AND REDEFINE? (NOT 
                                                                                        FORGET-EXPRS?
                                                                                         ))
                                                                     :SAVE)
                                                                    (REDEFINE? T)
                                                                    (T NIL))))
                                ((TCOMPL BCOMPL)             (* ; "The old ByteCompiler")
                                     [IF (MEMB (CAR OPTIONS)
                                                   '(ST F S STF))
                                         THEN (LISPXUNREAD (LIST (CAR OPTIONS]
                                     [IF GROUP
                                         THEN 

                                               (* ;; 
                                   "File contained in FILEGROUP.  Therefore must be blockcompiled.")

                                               (IF RECOMPFLG
                                                   THEN (BRECOMPILE GROUP)
                                                 ELSE (BCOMPL GROUP))
                                       ELSEIF (EQ COMPILER 'TCOMPL)
                                         THEN (IF RECOMPFLG
                                                      THEN (RECOMPILE FILE)
                                                    ELSE (TCOMPL (LIST FILE)))
                                       ELSE (IF RECOMPFLG
                                                    THEN (BRECOMPILE FILE)
                                                  ELSE (BCOMPL (LIST FILE])
                                (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?...")))
                  T T])

(COMPILE-FILE?
  [LAMBDA (ROOTNAME)                                     (* ; "Edited 19-Jan-87 21:12 by Pavel")

(* ;;; "Which compiler should CLEANUP use?")

    (LET ((TYPE (GET ROOTNAME 'FILETYPE))
          (UNKNOWN NIL))
         (FOR X INSIDE TYPE DO (SELECTQ X
                                               ((TCOMPL :TCOMPL) 
                                                    (RETURN 'TCOMPL))
                                               ((BCOMPL :BCOMPL) 
                                                    (RETURN 'BCOMPL))
                                               ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) 
                                                    (RETURN 'FAKE-COMPILE-FILE))
                                               ((:COMPILE-FILE :XCL-COMPILE-FILE) 
                                                    (RETURN 'CL:COMPILE-FILE))
                                               ((CLISP) 
                                                    NIL)
                                               (SETQ UNKNOWN T))
            FINALLY (IF UNKNOWN
                            THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE
                                            ))
                  (RETURN *DEFAULT-CLEANUP-COMPILER*])

(MAKEFILES
  [LAMBDA (OPTIONS FILES)                                (* rmk%: "23-FEB-83 21:20")
    (RESETVARS (%#UNDOSAVES)                                 (* ; 
                                                   "Willing to save arbitrary amounts of undo info")
               (UPDATEFILES)
               [COND
                  ((NULL FILES)
                   (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE
                                                                         (COND
                                                                            ((NULL FLG)
                                                             (* ; "Gets printed the first time")
                                                                             
                                                                             '
                                        "****NOTE: the following are not contained on any file:
    ")
                                                                            (T '"    "]
                      do (SETQ FLG T) finally (AND FLG (ADDTOFILES?]
               (SETQ OPTIONS (MKLIST OPTIONS))
               (RETURN (for FILE inside (OR FILES FILELST)
                          when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP
                                                                          of (ROOTFILENAME FILE]
                          collect (LISPXPRIN2 FILE T T)
                                (LISPXPRIN1 '|...| T)
                                (PROG1 (MAKEFILE FILE OPTIONS)
                                       (LISPXTERPRI T])

(ADDFILE
  [LAMBDA (FILE LOADTYPE PRLST FCLST)                    (* bvm%: "29-Aug-86 12:22")

    (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           FLST VAL)
          [COND
             ((NOT FCLST)
              (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE)))
             [(NULL (CDR FCLST))                             (* ; "A simple symbolic file")
              (SETQ FCLST (CAR FCLST))
              (SETQ VAL (ADDFILE0 (COND
                                         ((LITATOM (CADR FCLST))
                                          (ROOTFILENAME (CADR FCLST)))
                                         (T ROOTNAME))
                               LOADTYPE FILE (CAR FCLST]
             (T 
                (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.")

                (SELECTQ LOADTYPE
                    ((T LOADFNS) 
                         (SETQ LOADTYPE 'Compiled))
                    (loadfns (SETQ LOADTYPE 'compiled))
                    (LOADCOMP                                (* ; 
                   "loadcomp on compiled file.  Don't notice since we don't know what its state is")
                              NIL)
                    (SHOULDNT))
                (for X in (CDR FCLST) when (LITATOM (CADR X))
                   do (push FLST (CADR X))
                         (OR (EQ LOADTYPE 'LOADCOMP)
                             (ADDFILE0 (ROOTFILENAME (CADR X))
                                    LOADTYPE
                                    (CADR X)
                                    (CAR X]
          (UPDATEFILES PRLST (OR FLST (LIST FILE)))
          [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES
                           when (AND (LITATOM TYPE)
                                         (SETQ CHANGED (fetch CHANGED of TYPE)))
                           do (/replace CHANGED of TYPE
                                     with (INTERSECTION (CDR (ASSOC TYPE PRLST))
                                                     CHANGED]
          (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS))
          (RETURN VAL])

(ADDFILE0
  [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT)               (* lmm "28-Nov-84 16:47")
    (PROG (COMS X FILEPROP FLG TEM)
      TOP (SETQ COMS (FILECOMS ROOTNAME))
          [COND
             ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME))
              (COND
                 ([AND LOADTYPE (FMEMB LOADTYPE
                                       (CDR (FMEMB (fetch LOADTYPE of FILEPROP)
                                                   '(LOADCOMP loadfns compiled Compiled LOADFNS 
                                                           COMPILED NIL T]
                  (/replace LOADTYPE of FILEPROP with LOADTYPE)

                  (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property.  'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file.  'Compiled' means all but DECLARE: expressions are in.  e.g. user does LOAD of a compiled file.  COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.  LOADFNS means everything in, e.g. user des LOADFROM symbolic file.  COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted.  NIL is a makefile when coms were set up in core.  T is full load of symbolic file.  The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.")

                  (* ;; "LOADCOMP means file was loadcomp'ed.  note that the actual structure is a tree, not a list, and the above is only an approximation.  if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc.  however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.")

                  (GO OUT))
                 (T (GO OUT1]
          (COND
             [(OR LOADTYPE (LISTP (GETTOPVAL COMS)))
              (SETQ FILEPROP (/replace FILEPROP of ROOTNAME
                                with (create FILEPROP
                                                COMSNAME _ COMS
                                                LOADTYPE _ LOADTYPE]
             (FLG (GO ERROR))
             ((AND DWIMFLG (EQ ROOTNAME FULLNAME)
                   (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T)))

              (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.")

              (SETQ FULLNAME ROOTNAME)
              (SETQ FLG T)                                   (* ; 
                                         "so wont try to spelling correct again if file isnt there")
              (GO TOP))
             (T (GO ERROR)))
      OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME
                               with (LIST (create FILEDATEPAIR
                                                     FILEDATE _ DAT
                                                     DATEFILENAME _ FULLNAME]
          (AND (EQ LOADTYPE T)
               (/replace TOBEDUMPED of FILEPROP with NIL))
      OUT1
          [COND
             ([AND (LISTP (GETTOPVAL COMS))
                   (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ; 
                                                          "coms wuld not be set up on a loadccomp.")
              (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST]
          (RETURN (COND
                     ((NULL LOADTYPE)                        (* ; "call from makefile.")
                      (CONS FULLNAME (CONS ROOTNAME FILEPROP)))
                     (T FILEPROP)))
      ERROR
          (ERROR FULLNAME "not file name." T])

(LISTFILES
  [NLAMBDA FILES                                         (* rmk%: " 3-Dec-84 08:58")
    (DECLARE (GLOBALVARS NOTLISTEDFILES))                (* ; "LISTFILES1 is machinedependent")
    (for FILE FULLNAME OPTIONS in (COND
                                             (FILES (SETQ FILES (NLAMBDA.ARGS FILES)))
                                             (T NOTLISTEDFILES))
       when (COND
                   ((LISTP FILE)
                    (SETQ OPTIONS (APPEND FILE OPTIONS))
                    NIL)
                   ((SETQ FULLNAME (FINDFILE FILE))
                    FULLNAME)
                   (T (printout T FILE " not found." T)
                      NIL)) collect [COND
                                           ((LISTFILES1 FULLNAME OPTIONS)
                                            (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
                                                                        NOTLISTEDFILES]
                                  FULLNAME])
)

(RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)

(RPAQ? FILELST )

(RPAQ? LOADEDFILELST )

(RPAQ? NOTLISTEDFILES )

(RPAQ? NOTCOMPILEDFILES )

(RPAQ? MAKEFILEFORMS )

(RPAQ? NILCOMS )

(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP%  F ST STF
                                 (REC . RC)
                                 (BREC . RC)
                                 (TC . C)
                                 (BC . C)
                                 (TCOMPL . C)
                                 (BCOMPL . C))

(RPAQ? MAKEFILEREMAKEFLG T)

(RPAQ? CLEANUPOPTIONS '(RC))



(* ;; "scanning file coms")

(DEFINEQ

(FILEPKGCHANGES
  [LAMBDA N                                              (* Pavel " 7-Oct-86 19:22")
    (COND
       [(EQ N 0)
        (PROG (TEM)
              (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X)
                                                                   (SETQ TEM (FILEPKGCHANGES
                                                                              X)))
                         collect (CONS X TEM]
       [(EQ (ARG N 1)
            T)
        (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES
                                                                                 X]
       [(EQ N 1)
        (COND
           [(LISTP (ARG N 1))
            (for X in (ARG N 1) when (FMEMB (CAR X)
                                                        FILEPKGTYPES)
               do (/replace CHANGED of (CAR X) with (CDR X]
           (T (for Y on (fetch CHANGED of (ARG N 1))
                 when [AND (CAR Y)
                               (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y)
                                                                                 Z]
                 collect (CAR Y]
       (T (/replace CHANGED of (ARG N 1) with (ARG N 2])

(GETFILEPKGTYPE
  [LAMBDA (TYPE ONLY NOERROR NAME)                       (* lmm "20-Nov-86 23:10")

    (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ")

    (COND
       [(LISTP TYPE)

        (* ;; " given a list of types, coerce them all or return NIL")

        (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME)
                                               (RETURN]
       ((EQ TYPE '?)

        (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ")

        (AND NAME (TYPESOF NAME)))
       [(AND (NEQ ONLY 'COMS)
             (OR (SELECTQ TYPE
                     (NIL 'FNS)
                     (T 'VARS)
                     NIL)
                 (for X in FILEPKGTYPES do (if (EQ TYPE X)
                                                           then 

                                                                 (* ;; "type matched exactly")

                                                                 (RETURN TYPE)
                                                         elseif (AND (LISTP X)
                                                                         (EQ TYPE (CAR X)))
                                                           then (RETURN (CDR X]
       [(AND (NEQ ONLY 'TYPE)
             (LITATOM TYPE)
             (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST))       (* ; "Prefer an exact match quickly")
                    ]
       [(AND (NEQ ONLY 'COMS)
             (LITATOM TYPE)
             (for X in FILEPKGTYPES bind NAME
                do (SETQ NAME (if (NLISTP X)
                                      then X
                                    else (CAR X))) 

                      (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization")

                      (AND (<= 0 (- (NCHARS NAME)
                                    (NCHARS TYPE))
                               1)
                           (STRPOS TYPE NAME)
                           (RETURN (if (EQ X NAME)
                                       then X
                                     else (CDR X]
       [(FIXSPELL TYPE NIL (SELECTQ ONLY
                               (TYPE FILEPKGTYPES)
                               (COMS FILEPKGCOMSPLST)
                               (UNION FILEPKGTYPES FILEPKGCOMSPLST]
       ((NOT NOERROR)
        (ERROR (SELECTQ ONLY
                   (TYPE "unrecognized manager definition type")
                   (COMS "unrecognized manager command")
                   "unrecognized manager definition-type/command")
               TYPE])

(MARKASCHANGED
  [LAMBDA (NAME TYPE REASON)                             (* ; "Edited 25-May-88 15:37 by drc:")
    (COND
       (FILEPKGFLG (SETQ REASON (SELECTQ REASON
                                    ((CLISP LOAD CHANGED DEFINED DELETED) 
                                         REASON)
                                    (NIL 'CHANGED)
                                    (T 'DEFINED)
                                    (ERROR "bad REASON in MARKASCHANGED" REASON)))
              (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (for FN inside (fetch WHENCHANGED of TYPE)
                 do (APPLY* FN NAME TYPE REASON))
              (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON))
              [COND
                 ((EQ REASON 'DELETED)
                  (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L)
                                                                                    NAME)
                     do (/RPLACA L NIL))                 (* ; 
                                                          "unmark as changed and remove from files")
                  (DELFROMFILES NAME TYPE))
                 (T (LET ((LST (push (fetch CHANGED of TYPE)
                                      NAME)))
                         (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST)
                                               LISPXHIST))   (* ; 
                             "UNDO by smashing with NIL;  makes calls to MARKASCHANGED independent")
                         ]
              NAME])

(FILECOMS
  [LAMBDA (FILE X)                                       (* rmk%: "19-FEB-83 13:55")
    (COND
       ((AND (NULL FILE)
             (NULL X))
        'NILCOMS)
       [(AND (OR (NULL X)
                 (EQ X 'COMS))
             (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE]
       (T (PACK* (NAMEFIELD FILE)
                 (OR X 'COMS])

(WHEREIS
  [LAMBDA (NAME TYPE FILES FN)                        (* ; "Edited 12-Jul-88 17:14 by MASINTER")

    (* ;; "T as a NAME has a special meaning to INFILECOMS?  so don't pass through.")

    (CL:UNLESS (EQ NAME T)
        (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES)
                                           FILELST)
                                      (FUNCTION (LAMBDA (FILE)
                                                  (INFILECOMS? NAME TYPE (FILECOMS FILE]
                               (AND (EQ FILES T)
                                    (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS)
                                    (LET ((FILES NIL))
                                         (for TY inside TYPE
                                            do (for FILE-NAME
                                                      in (XCL::HASH-FILE-WHERE-IS NAME
                                                                    (GETFILEPKGTYPE TYPE))
                                                      do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME))
                                                                    FILES)))
                                         (REVERSE FILES]
             (CL:IF FN
                 [MAPC IN-FILES (FUNCTION (LAMBDA (FILE)
                                            (APPLY* FN NAME FILE]
                 IN-FILES)))])

(SMASHFILECOMS
  [LAMBDA (FILE)                                         (* rmk%: "19-FEB-83 22:15")
    (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X)
       do (SETTOPVAL X 'NOBIND))
    FILE])

(FILEFNSLST
  [LAMBDA (FILE)                                         (* ; "Edited 14-Jun-90 19:30 by jds")
    (FILECOMSLST FILE '(FUNCTIONS FNS])

(FILECOMSLST
  [LAMBDA (FILE TYPE FLG)                                (* JonL "24-Jul-84 19:48")
                                                             (* ; 
                                                    "TYPE is coerced in the innards of INFILECOMS?")
    (COND
       ((EQ FLG 'UPDATE)
        (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE)
                    FLG)))
       (T (INFILECOMS? NIL TYPE (FILECOMS FILE)
                 FLG])

(UPDATEFILES
  [LAMBDA (PRLST FLST)                                   (* rmk%: "19-FEB-83 14:27")

    (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g.  LOAD, LOADFNS) involving the files in FLST began.")

    (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE))
       do (COND
                 ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE)))
                                                             (* ; 
                                                           "FILEPKGCHANGES eliminates duplicates")
                  (/replace CHANGED of TYPE with NIL))
                 (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES
                           (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST
                       first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) 

                             (* ;; "First check NIL=Nowhere.  LST:1 contains variables whose values are on the file literally.  These are `found' but not marked.  LST::1 contains all other items.")

                             (SETQ FOUND (NCONC (CAR LST)
                                                (CDR LST)
                                                FOUND))
                       do (SETQ PCHANGES (COND
                                                ((FMEMB (fetch DATEFILENAME
                                                           of (CAR (fetch FILEDATES
                                                                          of FILE)))
                                                        FLST)

                                 (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began.  Thus, by this intersection we only worry about items that were previously changed;  any items that were only changed during this operation are ignored.")

                                                 (INTERSECTION CHANGED PREVITEMS))
                                                (T CHANGED)))
                             [COND
                                ([AND PCHANGES [SETQ COMS (fetch COMSNAME
                                                             of (SETQ FILEPROP
                                                                     (LISTP (fetch FILEPROP
                                                                               of FILE]
                                      (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE]

                                 (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms")

                                 [COND
                                    ((CDR LST)               (* ; "CDR items must be distributed")
                                     [COND
                                        ((NULL (fetch TOBEDUMPED of FILEPROP))

                                         (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL")

                                         [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL
                                                                                   'NOTLISTEDFILES]
                                         (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE
                                                                              (GETTOPVAL 
                                                                                     '
                                                                                     NOTCOMPILEDFILES
                                                                                     ]
                                                             (* ; 
                                                   "Get the (possibly new) TYPE item list to smash")
                                     [COND
                                        [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED
                                                                        of FILEPROP]
                                        (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE]
                                                             (* ; 
                                                        "Now distribute items to the file property")
                                     (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP)
                                                                                   )
                                        do (/NCONC1 TYPEDPROP Y]
                                 (SETQ FOUND (NCONC (CAR LST)
                                                    (CDR LST)
                                                    FOUND] finally (/replace CHANGED
                                                                          of TYPE
                                                                          with (LDIFFERENCE
                                                                                    CHANGED FOUND])

(INFILECOMS?
  [LAMBDA (NAME TYPE COMS ONFILETYPE)                 (* ; "Edited 12-Jul-88 17:42 by MASINTER")

    (* ;; "Returns T if NAME is 'CONTAINED' in COMS.  If NAME is NIL, then value is a list of all of the functions contained in COMS.  If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.)  Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1.  while elements are the subset of NAME which are on the file in other case")

    (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS?  returns the dotted pair of (literals  . elements) where literals are those which are `literally' on the file (e.g.  (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")

    (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ")

    (PROG (VAL LITERALS ORIGFLG)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (SELECTQ ONFILETYPE
              (EDIT (SELECTQ TYPE
                        (FILEVARS (RETURN))
                        NIL))
              NIL)
          [COND
             ((LITATOM COMS)
              (SELECTQ TYPE
                  ((VARS FILEVARS)                           (* ; 
                                                           "the COMS of a file are also on it")
                       (INFILECOMSVAL COMS))
                  NIL)
              (SETQ COMS (EVALV COMS]
          (INFILECOMS COMS)
          (SETQ VAL (DREVERSE VAL))
          (RETURN (COND
                     ((EQ ONFILETYPE 'UPDATE)
                      (CONS LITERALS VAL))
                     (T VAL])

(INFILECOMTAIL
  [LAMBDA (COM FLG)                                   (* ; "Edited  2-Aug-88 02:15 by masinter")
    [SETQ COM (COND
                 ((EQ (CADR COM)
                      '*)
                  (COND
                     [(LITATOM (CADDR COM))
                      (LISTP (EVALV (CADDR COM]
                     (T [RESETVARS (DWIMLOADFNSFLG)
                                   (NLSETQ (SETQ COM (EVAL (CADDR COM]
                        COM)))
                 (T (CDR COM]
    (if (NOT FLG)
        then (for X in COM
                    do [if (AND (LISTP X)
                                        (EQ (CAR X)
                                            COMMENTFLG))
                               then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X)
                                                                        (OR (NLISTP X)
                                                                            (NEQ (CAR X)
                                                                                 COMMENTFLG]
                    finally (RETURN COM))
      else COM])

(INFILECOMS
  [LAMBDA (COMS)                                         (* rmk%: "19-FEB-83 22:17")
    (for X in COMS do (INFILECOM X])

(INFILECOM
  [LAMBDA (COM)                                       (* ; "Edited  2-Aug-88 02:27 by masinter")
    (COND
       [(NLISTP COM)
        (COND
           ((EQ TYPE 'VARS)
            (INFILECOMSVAL COM]
       ((EQ (CAR COM)
            COMMENTFLG)

        (* ;; 
"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
                                                             (* ; 
  "don't know why I should bother, but someone might want to know all of the comments on a file???")
        (COND
           ((EQ TYPE COMMENTFLG)
            (INFILECOMSVAL COM T)))
        NIL)
       (T
        (PROG ((COMNAME (CAR COM))
               (TAIL (CDR COM))
               CFN TEM)
              (COND
                 [[COND
                     ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
                      (SETQ TEM (APPLY* CFN COM (COND
                                                   ((AND (NULL ONFILETYPE)
                                                         (NOT (CL:SYMBOLP NAME)))
                                                             (* ; 
                                                "call from WHEREIS of a name which is not a symbol")
                                                    (LIST NAME))
                                                   (T NAME))
                                       TYPE ONFILETYPE)))
                     ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
                                                             (* ; "for compatability")
                      (SETQ TEM (APPLY* CFN COM TYPE NAME]
                  (COND
                     [(NLISTP TEM)
                      (COND
                         ((EQ TEM T)
                          (COND
                             ((OR (EQ NAME T)
                                  (NULL ONFILETYPE))
                              (RETFROM 'INFILECOMS? T]
                     (T (INFILECOMSVALS TEM]
                 ((LISTP TAIL)

                  (* ;; "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")

                  (SELECTQ COMNAME
                      ((PROP IFPROP) 
                           (SETQ TAIL (CDR TAIL)))
                      NIL)
                  [COND
                     ((EQ (CAR TAIL)
                          '*)
                      (COND
                         ((LITATOM (CADR TAIL))
                          (SELECTQ TYPE
                              ((VARS FILEVARS) 
                                   (INFILECOMSVAL (CADR TAIL)))
                              NIL))
                         ((AND (LISTP (CADR TAIL))
                               (EQ ONFILETYPE 'UPDATE)
                               (EQ TYPE 'VARS)
                               (EQ (CAADR TAIL)
                                   'PROGN)
                               (FMEMB (CAR (LAST (CADR TAIL)))
                                      NAME))
                          (SETQ VAL (CONS (CADR TAIL)
                                          VAL]
                  (SELECTQ COMNAME
                      ((COMS EXPORT) 
                           (INFILECOMS (INFILECOMTAIL COM T)))
                      (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM)
                                                           T)))
                      (DECLARE%:                             (* ; "skip over DECLARE: tags")
                                 [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM))
                                              (IFCDECLARE (INFILECOMTAIL COM)
                                                     (EQ TYPE 'DECLARE%:])
                      (ORIGINAL                              (* ; "dont expand macros")
                                (PROG ((ORIGFLG T))
                                      (INFILECOMS (INFILECOMTAIL COM T))))
                      ((PROP IFPROP)                         (* ; 
                                       "this currently does not handle `pseudo-types' of PROPNAMES")
                           (SELECTQ TYPE
                               (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM)
                                                              T)
                                             (CADR COM)))
                               (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
                                              (CADR COM)))
                               NIL))
                      (PROPS (RETURN (IFCPROPS COM)))
                      (MACROS (RETURN (SELECTQ TYPE
                                          (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T)
                                                        MACROPROPS))
                                          (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T)))
                                          NIL)))
                      (ALISTS                                (* ; 
                      "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")
                              (RETURN (SELECTQ TYPE
                                          (ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
                                          NIL)))
                      (P [RETURN (SELECTQ TYPE
                                     ((EXPRESSIONS P) 
                                          (INFILECOMSVALS (INFILECOMTAIL COM T)
                                                 T))
                                     (COND
                                        ((NULL ONFILETYPE)   (* ; "for WHEREIS and FILECOMSLST")
                                         (SELECTQ TYPE
                                             (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR))
                                             (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE))
                                             NIL])
                      ((ADDVARS APPENDVARS) 
                           (SELECTQ TYPE
                               (VARS [RETURN (AND (NULL ONFILETYPE)
                                                  (for X in (INFILECOMTAIL COM T)
                                                     do (INFILECOMSVAL (CAR X)
                                                                   T])
                               (ALISTS [RETURN (for X in (INFILECOMTAIL COM T)
                                                  when (EQMEMB 'ALIST (GETPROP (CAR X)
                                                                                 'VARTYPE))
                                                  do (for Z in (CDR X)
                                                            do (INFILECOMSVAL
                                                                    (LIST (CAR X)
                                                                          (CAR Z))
                                                                    T])
                               (OR (EQ TYPE COMNAME)
                                   (RETURN))))
                      ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) 
                           [RETURN (COND
                                      ((EQ TYPE 'EXPRESSIONS)
                                       (for X in (INFILECOMTAIL COM T)
                                          when (AND (LISTP X)
                                                        (NEQ (CAR X)
                                                             COMMENTFLG))
                                          do (INFILECOMSVAL (CONS 'SETQ X)
                                                        T)))
                                      ((OR (EQ TYPE 'VARS)
                                           (EQ TYPE COMNAME))(* ; 
                   "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
                                       (for X in (INFILECOMTAIL COM T)
                                          do (COND
                                                    ((LISTP X)
                                                     (AND (CAR X)
                                                          (NEQ (CAR X)
                                                               COMMENTFLG)
                                                          (INFILECOMSVAL (CAR X)
                                                                 T)))
                                                    (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS])
                      (DEFS [RETURN (for X in (INFILECOMTAIL COM T)
                                       when (EQ TYPE (CAR X)) do (INFILECOMSVALS
                                                                          (CDR X])
                      (FILES (RETURN))
                      NIL)

                  (* ;; "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")

                  (COND
                     ((EQ COMNAME TYPE)
                      (INFILECOMSVALS (INFILECOMTAIL COM T)))
                     [(AND (LISTP TYPE)
                           (FMEMB COMNAME TYPE))
                      (LET ((TYPE COMNAME))
                           (INFILECOMSVALS (INFILECOMTAIL COM T]
                     ((AND (OR (NULL CFN)
                               (AND (EQ CFN T)
                                    (NULL ONFILETYPE)))
                           (NULL ORIGFLG)
                           (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
                      (INFILECOMS (SUBPAIR (CAR TEM)
                                             (INFILECOMTAIL COM T)
                                             (CDR TEM])

(INFILECOMSVALS
  [LAMBDA (X FLG)                                     (* ; "Edited  2-Aug-88 02:21 by masinter")
    (for Y in X when (NOT (AND (LISTP Y)
                                           (EQ (CAR Y)
                                               COMMENTFLG))) do (INFILECOMSVAL Y FLG])

(INFILECOMSVAL
  [LAMBDA (X FLG)                                     (* ; "Edited 12-Jul-88 17:56 by MASINTER")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND (OR (NULL NAME)
                 (MEMBER X NAME))
             (COND
                (FLG (SETQ LITERALS (CONS X LITERALS)))
                (T (SETQ VAL (CONS X VAL]
       ((AND (EQ ONFILETYPE 'EDIT)
             FLG)                                            (* ; 
                                        "literals should not be edited as they are on the fileCOMS")
        NIL)
       ((EQ ONFILETYPE 'TYPESOF)
        (AND (COND
                ((LITATOM NAME)
                 (EQ NAME X))
                (T (EQUAL NAME X)))
             (CL:PUSHNEW TYPE VAL)))
       ([OR (EQ NAME T)
            (COND
               ((LITATOM NAME)
                (EQ NAME X))
               (T (EQUAL NAME X]
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS X VAL])

(INFILECOMSPROP
  [LAMBDA (AT PROP)                                      (* lmm "25-SEP-81 17:15")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND [OR (NULL NAME)
                 (find X in NAME suchthat (AND (EQ (CAR X)
                                                               AT)
                                                           (EQ (CADR X)
                                                               PROP]
             (SETQ VAL (CONS (LIST AT PROP)
                             VAL]
       ((OR (EQ NAME T)
            (AND (EQ (CAR NAME)
                     AT)
                 (EQ (CADR NAME)
                     PROP)))
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS (LIST AT PROP)
                        VAL])

(IFCPROPS
  [LAMBDA (COM)                                          (* bvm%: " 2-Dec-83 14:24")

(* ;;; "Examine a PROPS com for objects of specified TYPE")

    (SELECTQ TYPE
        (PROPS                                               (* ; 
                                       "the PROPS command can actually take (PROPNAME at1 at2 ...)")
               (INFILEPAIRS (INFILECOMTAIL COM)))
        (PROP                                                (* ; 
                                                "return the atoms which have any properties at all")
              (for PAIR in (INFILECOMTAIL COM) do (for ATNAME
                                                                     inside (CAR PAIR)
                                                                     do (INFILECOMSVAL ATNAME
                                                                                   ))))
        (MACROS                                              (* ; "only MACRO properties")
                (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR)
                                                                           (CDR PAIR))))
        NIL])

(IFCEXPRTYPE
  [LAMBDA (COM FN)                                       (* ; "Edited  6-Apr-87 20:20 by Pavel")

(* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN")

    (for SUBCOM in (INFILECOMTAIL COM)
       when (AND (EQ (CAR SUBCOM)
                         FN)
                     (EQ (CAR (LISTP (CADR SUBCOM)))
                         'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM))
                                                T])

(IFCPROPSCAN
  [LAMBDA (ATOMS PROPNAMES)                           (* ; "Edited  2-Aug-88 02:20 by masinter")

(* ;;; 
"Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES")

    (for AT in ATOMS WHEN (LITATOM AT) unless [COND
                                                                 [(EQ ONFILETYPE 'UPDATE)
                                                                  (COND
                                                                     (NAME (NOT (ASSOC AT NAME]
                                                                 ((LISTP NAME)
                                                                  (NEQ AT (CAR NAME]
       do (COND
                 ((EQ PROPNAMES 'ALL)
                  (for PROP in (GETPROPLIST AT) by (CDDR PROP)
                     when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP)))
                 (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])

(IFCDECLARE
  [LAMBDA (TAIL WANTDECLARE)                          (* ; "Edited  8-Jun-90 18:11 by teruuchi")
    (PROG ((TAIL TAIL))
      LP  (COND
             ((LISTP TAIL)
              [SELECTQ (CAR TAIL)
                  ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                       [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
                                                                 (CADR TAIL]
                       (SETQ TAIL (CDR TAIL)))
                  (DONTEVAL@LOAD [COND
                                    ((OR (\STKSCAN 'DOFILESLOAD)
                                         (\STKSCAN 'LOAD))
                                                  (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"")
                                     (RETURN))
                                    (WANTDECLARE (INFILECOMSVAL (CAR TAIL])
                  (COMPILERVARS (RETURN))
                  (COND
                     [(FMEMB (CAR TAIL)
                             DECLARETAGSLST)
                      (COND
                         (WANTDECLARE (INFILECOMSVAL (CAR TAIL]
                     (T (INFILECOM (CAR TAIL]
              (SETQ TAIL (CDR TAIL))
              (GO LP])

(INFILEPAIRS
  [LAMBDA (LST)                                          (* lmm " 4-DEC-78 09:51")
    (for LL in LST do (for X inside (CAR LL)
                                     do (for Y inside (CDR LL)
                                               do (INFILECOMSVAL (LIST X Y])

(INFILECOMSMACRO
  [LAMBDA (ATS PROPS)                                    (* lmm "28-SEP-78 18:35")

    (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.  --- Normally (e.g.  for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom.  However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties")

    (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE)
                                               (EVERY (PROPNAMES AT)
                                                      (FUNCTION (LAMBDA (X)
                                                                  (OR (NOT (FMEMB X MACROPROPS))
                                                                      (EQMEMB X PROPS]
                                           [SOME MACROPROPS (FUNCTION (LAMBDA (PROP)
                                                                        (EQMEMB PROP PROPS]
                                           (INFILECOMSVAL AT])
)



(* ;; "adding to a file")

(DEFINEQ

(FILES?
  [LAMBDA NIL                                            (* bvm%: "27-Oct-86 18:14")

(* ;;; 
"Display each file needing dumping, etc.  For files needing dumping, display details of why.")

    (UPDATEFILES)
    (LET (FILES CHANGES PRINTED)
         (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED
                                                                of (LISTP (fetch FILEPROP
                                                                                 of FILE]
            do (if (NOT PRINTED)
                       then (LISPXPRIN1 "To be dumped:
" T)
                             (SETQ PRINTED T))
                  (LISPXPRIN2 FILE T)
                  (LISPXPRIN1 " ...changes to " T)
                  [for CH in CHANGES bind TB
                     do (COND
                               ((LISTP CH)
                                [COND
                                   (TB (LISPXTAB TB NIL T))
                                   (T (SETQ TB (POSITION T]
                                (LISPXPRIN2 (CAR CH)
                                       T)
                                (FILES?PRINTLST (CDR CH)))
                               (T                            (* ; "old style")
                                  (LISPXPRIN2 CH T)
                                  (LISPXSPACES 1 T]
                  (LISPXTERPRI T))
         (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED "    plus "))
            do (SETQ FLG T) finally (if FLG
                                                then (OR PRINTED (LISPXPRIN1 "...to be dumped.  "
                                                                            T))
                                                      (ADDTOFILES?)))
         (if (SETQ FILES NOTCOMPILEDFILES)
             then (FILES?PRINTLST FILES "To be compiled: ")
                   (LISPXTERPRI T))
         (if (SETQ FILES NOTLISTEDFILES)
             then (FILES?PRINTLST FILES "To be listed: ")
                   (LISPXTERPRI T))
         (CL:VALUES])

(FILES?1
  [LAMBDA (TYPE FIRST)                                   (* bvm%: "27-Oct-86 18:17")

    (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.")

    (LET (STR LST)
         (COND
            ([AND (LITATOM TYPE)
                  (SETQ STR (fetch DESCRIPTION of TYPE))
                  (LISTP (SETQ LST (fetch CHANGED of TYPE]
             (AND FIRST (LISPXPRIN1 FIRST T))
             (LISPXPRIN1 '"the " T)
             (LISPXPRIN1 STR T)
             (FILES?PRINTLST LST)
             (LISPXTERPRI T)
             T])

(FILES?PRINTLST
  [LAMBDA (LST STR)                                      (* bvm%: "27-Oct-86 18:15")

    (* ;; "Print elements of LST separated by commas and indenting new lines a bunch.  If MAPRINT had a left margin arg, this would be simpler.")

    (MAPRINT LST T (OR STR ": ")
           NIL ", " [FUNCTION (LAMBDA (STR)
                                (COND
                                   ((> (+ (POSITION T)
                                          (NCHARS STR T T)
                                          3)
                                       (LINELENGTH NIL T))
                                    (LISPXTERPRI T)
                                    (LISPXPRIN1 "         " T)))
                                (LISPXPRIN2 STR T T]
           T])

(ADDTOFILES?
  [LAMBDA (NOASKSTR)                                    (* ; "Edited 10-Aug-2020 21:18 by rmk:")
                                                             (* ; "Edited 21-Aug-91 10:13 by jds")

    (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says")

    (* ;; "RMK: Eliminated literal CR's in the key list.")

    (ERSETQ
     (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS]

      (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g.  changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES")

           [COND
              (NOASKSTR (PRIN1 NOASKSTR T))
              (T (DOBE)
                 (SETQ BUFS (READP T))
                 (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go")
                                 `([Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL]
                                   [N ,(CONCAT "o" (CHARACTER (CHARCODE EOL]
                                   (%] ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
                                       EXPLAINSTRING 
                                       "] - nowhere, all items will be marked as dummy
" NOECHOFLG T))
                                 T)
                     (N (RETURN))
                     (%]                                     (* ; "Nowhere")
                         (for TYPE in FILEPKGTYPES
                            do (for NAME in (fetch (FILEPKGTYPE CHANGED)
                                                           of TYPE)
                                      do (ADDTOFILE NAME TYPE NIL)))
                         (RETURN))
                     NIL)                                    (* ; 
                              "if there was type-ahead BEFORE the askuser, then don't allow it now")
                 (COND
                    (BUFS (SETQ BUFS (COND
                                        ((READP T)
                                         (LINBUF)
                                         (SYSBUF)
                                         (SETQ BUFS (CLBUFS NIL T READBUF]
           [for TYPE STR LST in FILEPKGTYPES
              when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
                            (LISTP (SETQ LST (COND
                                                ((EQ TYPE 'VARS)
                                                 VARSCHANGES)
                                                (T (fetch (FILEPKGTYPE CHANGED) of TYPE]
              do
              (printout T "(" STR ")" T)
              (for NAME TEM FILE in LST when NAME
                 do
                 (PROG NIL
                   LP  (PRIN2 NAME T)
                       (SPACES 2 T)

                  (* ;; "if user typed ahead before entering addtofiles??  then dont allow typeahead here, because it will justgobble his earlier typeahead.")

                  (* ;; "SELCHARQ to avoid literal CR")

                       (SELCHARQ (CHCON1 (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T)))
                            (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)

                                 (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer")

                                               (DOBE)))
                                (GO LP))
                            (%]                              (* ; "Nowhere")
                                (SETQ FILE))
                            (SPACE                           (* ; "No action")
                                   (RETURN))
                            ((LF =) 
                                 (PRINT (OR (SETQ FILE LASTFILE)
                                            'Nowhere)
                                        T))
                            (SETQ FILE TEM))
                       (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
                                         (SETQ PLACE (WHATIS FILE NIL TYPE))
                                         [COND
                                            ((LITATOM PLACE) (* ; "file name")
                                             (SETQ FILE PLACE)
                                             (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                                                        NAME TYPE NEAR LISTNAME)
                                                 (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                          (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.")

                                             )
                                            ((EQ (CAR PLACE)
                                                 'Near%:)
                                             (SETQ NEAR (CADR PLACE))
                                             (COND
                                                ([SOME FILELST (FUNCTION (LAMBDA (FL)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           FL))
                                                                            NAME TYPE NEAR LISTNAME]
                                                 (PRINT (LIST 'on FILE)
                                                        T T))
                                                (T (PRINT (LIST (CADR PLACE)
                                                                'not
                                                                'found)
                                                          T T)
                                                   (ERROR!)))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE)))
                                            ([OR [UNDONLSETQ (PROGN (SAVESET
                                                                     (SETQ LISTNAME (CAR PLACE))
                                                                     (MERGEINSERT
                                                                      NAME
                                                                      (LISTP (GETTOPVAL LISTNAME))
                                                                      T)
                                                                     T
                                                                     'NOPRINT)
                                                                    (OR (SETQ FILE
                                                                         (CAR (WHEREIS NAME TYPE
                                                                                     FILELST)))
                                                                        (ERROR!]
                                                 (SOME FILELST (FUNCTION (LAMBDA (X)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           X))
                                                                            NAME TYPE NEAR LISTNAME]
                                             (PRIN1 "  value is filed on " T)
                                             (PRINT FILE T T)
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                 (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed")

                                             )
                                            (T (PRIN1 "    put list " T)
                                               (PRIN2 (CAR PLACE)
                                                      T T)
                                               (SETQ FILE
                                                (WHATIS (ASKUSER NIL NIL " on file: "
                                                                   '(("" "" EXPLAINSTRING 
                                                                         "a file name" KEYLST ()))
                                                                   T)
                                                       'FILE))
                                               (SAVESET (CAR PLACE)
                                                      (MERGEINSERT NAME
                                                             (LISTP (GETTOPVAL (CAR PLACE)))
                                                             T)
                                                      T
                                                      'NOPRINT)

                                     (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.")

                                               (ADDNEWCOM (FILECOMS FILE)
                                                      NAME TYPE (CAR PLACE)
                                                      FILE)
                                               (for F in (fetch WHENFILED of TYPE)
                                                  do (for I in (GETTOPVAL (CAR PLACE))
                                                            do (APPLY* F I TYPE FILE]
                                         (AND FILE (ADDFILE FILE))
                                         (SETQ LASTFILE PLACE)))
                           (GO LP]
           (AND BUFS (BKBUFS BUFS))
           (UPDATEFILES])

(ADDTOFILE
  [LAMBDA (NAME TYPE FILE NEAR LISTNAME)                 (* lmm "21-Nov-84 11:43")
                                                             (* ; "adds NAME to the file FILE")
    (PROG (TEM COMSNAME)
          [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T)
                         (COND
                            ((FMEMB TYPE FILELST)
                             (GETFILEPKGTYPE (swap TYPE FILE)))
                            (T (GETFILEPKGTYPE TYPE]
          (SETQ FILE (WHATIS FILE 'FILE))
          (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                     NAME TYPE NEAR LISTNAME)
              (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
          (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))
          (AND FILE (NOT (FMEMB FILE FILELST))
               (ADDFILE FILE))
          (RETURN FILE])

(WHATIS
  [LAMBDA (USERINPUT ONLY)                               (* lmm "28-Nov-84 16:49")

    (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble;  if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable")

    (PROG (TEM UCASE)
          (RETURN (COND
                     ((NULL USERINPUT)                       (* ; "nowhere")
                      NIL)
                     [(LISTP USERINPUT)
                      (COND
                         (ONLY (ERROR!))
                         (T (SELECTQ (CAR USERINPUT)
                                ((@ Near%:) 
                                     (CONS 'Near%: (CDR USERINPUT)))
                                (WHATIS (CAR USERINPUT)
                                       'LIST]
                     ([AND (NEQ ONLY 'LIST)
                           (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT)))
                                      FILELST)
                               (LISTP (GETTOPVAL (FILECOMS UCASE)))
                               (SETQ TEM (FIXSPELL UCASE NIL FILELST T]
                      TEM)
                     ((AND (NEQ ONLY 'FILE)
                           (LISTP (GETTOPVAL USERINPUT)))
                      (LIST USERINPUT))
                     ((AND (NEQ ONLY 'LIST)
                           (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE)
                                      NIL T)
                               'Y))
                      UCASE)
                     ((AND (NEQ ONLY 'FILE)
                           (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT)
                                      NIL T)
                               'Y))
                      (LIST USERINPUT))
                     (T                                      (* ; "none of above")
                        (ERROR!])

(ADDTOCOMS
  [LAMBDA (COMS NAME TYPE NEAR LISTNAME)                 (* rmk%: "10-JUN-82 22:53")

    (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms);  return NIL if unsuccessful.  If LISTNAME is given, then only insert by adding to LISTNAME.  If NEAR is given, only insert near it")

    (COND
       ((NULL COMS)
        NIL)
       [(LITATOM COMS)                                       (* ; 
      "given a name of a command;  rebind COMSNAME to current variable and try to add to its value")
        (OR [PROG ((COMSNAME COMS))
                  (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME))
                                 NAME TYPE NEAR (AND (NEQ COMS LISTNAME)
                                                     LISTNAME]
            (AND (EQ COMS LISTNAME)
                 (ADDNEWCOM COMS NAME TYPE]
       (T (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (for TAIL on COMS do (COND
                                              [(LISTP (CAR TAIL))
                                               (COND
                                                  ((ADDTOCOM (CAR TAIL)
                                                          NAME TYPE NEAR LISTNAME)
                                                   (RETURN T]
                                              (T (SELECTQ (CAR TAIL)
                                                     ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                                                          (SETQ TAIL (CDR TAIL)))
                                                     NIL])

(ADDTOCOM
  [LAMBDA (COM NAME TYPE NEAR LISTNAME)                  (* ; "Edited  2-May-87 19:04 by Pavel")
                                                             (* ; 
                        "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful")
    (PROG (TEM)
          (COND
             ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM]
              (RETURN)))
          [COND
             ((SETQ TEM (fetch ADD of (CAR COM)))
              (RETURN (COND
                         ((OR (NULL LISTNAME)
                              (INFILECOMS? LISTNAME 'FILEVARS (LIST COM)))
                          (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR))
                               (MARKASCHANGED COMSNAME 'VARS))
                          TEM]
          (RETURN
           (SELECTQ (CAR COM)
               (FNS (AND (EQ TYPE 'FNS)
                         (ADDTOCOM1 COM NAME NEAR LISTNAME)))
               ((VARS INITVARS) 
                    (COND
                       ((OR (EQ (CAR COM)
                                'VARS)
                            NEAR LISTNAME)                   (* ; 
                                  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.")
                        (SELECTQ TYPE
                            (EXPRESSIONS (COND
                                            ((EQ (CAR NAME)
                                                 'SETQ)
                                             (ADDTOCOM1 COM (CDR NAME)
                                                    NEAR LISTNAME))))
                            (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME))
                            NIL))))
               (COMS (ADDTOCOMS (COND
                                       [(EQ (CADR COM)
                                            '*)
                                        (COND
                                           ((LITATOM (CADDR COM))
                                            (CADDR COM))
                                           (T (RETURN]
                                       (T (CDR COM)))
                            NAME TYPE NEAR LISTNAME))
               (DECLARE%: (AND (OR LISTNAME NEAR)
                               (ADDTOCOMS (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     ((LITATOM (CADDR COM))
                                                      (CADDR COM))
                                                     (T (RETURN]
                                                 (T (CDR COM)))
                                      NAME TYPE NEAR LISTNAME)))
               (CL:EVAL-WHEN (AND (OR LISTNAME NEAR)
                                  (ADDTOCOMS (COND
                                                    [(EQ (CL:THIRD COM)
                                                         '*)
                                                     (COND
                                                        ((LITATOM (CL:FOURTH COM))
                                                         (CL:FOURTH COM))
                                                        (T (RETURN]
                                                    (T (CDDR COM)))
                                         NAME TYPE NEAR LISTNAME)))
               ((PROP IFPROP) 
                    (SELECTQ TYPE
                        (PROPS (COND
                                  ((EQ (CADR COM)
                                       (CADR NAME))
                                   (ADDTOCOM1 (CDR COM)
                                          (CAR NAME)
                                          NEAR LISTNAME))
                                  ((AND (EQ (CAR NAME)
                                            (CADDR COM))
                                        (NULL (CDDDR COM)))
                                   [/RPLACA (CDR COM)
                                          (UNION (MKLIST (CDR NAME))
                                                 (MKLIST (CADR COM]
                                   (MARKASCHANGED COMSNAME 'VARS)
                                   T)))
                        (MACROS (COND
                                   ([AND (for PROP inside (CADR COM)
                                            always (EQMEMB PROP MACROPROPS))
                                         (for PROP in MACROPROPS
                                            always (OR (EQMEMB PROP (CADR COM))
                                                           (NOT (GETPROP NAME PROP]

                                    (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")

                                    (ADDTOCOM1 (CDR COM)
                                           NAME NEAR LISTNAME))))
                        NIL))
               ((PROPS ALISTS) 
                    (AND (EQ TYPE (CAR COM))
                         (ADDTOCOM1
                          COM
                          (/NCONC1 (OR [ASSOC (CAR NAME)
                                              (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     [(LITATOM (CADDR COM))
                                                      (AND (OR (NULL LISTNAME)
                                                               (EQ (CADDR COM)
                                                                   LISTNAME))
                                                           (GETTOPVAL (CADDR COM]
                                                     (T (RETURN]
                                                 (T (CDR COM]
                                       (LIST (CAR NAME)))
                                 (CADR NAME))
                          NEAR LISTNAME)))
               (P (COND
                     ((AND (EQ TYPE 'EXPRESSIONS)
                           (NEQ (CAR NAME)
                                'SETQ))
                      (ADDTOCOM1 COM NAME NEAR LISTNAME))))
               (AND (EQ (CAR COM)
                        TYPE)
                    (ADDTOCOM1 COM NAME NEAR LISTNAME])

(ADDTOCOM1
  [LAMBDA (COM NAME NEAR LISTNAME)                       (* rmk%: " 3-JAN-82 22:53")
    (COND
       [(EQ (CADR COM)
            '*)                                              (* ; "add to list name")
        (AND [COND
                (LISTNAME (EQ (CADDR COM)
                              LISTNAME))
                (T (LITATOM (CADDR COM]
             (SAVESET (CADDR COM)
                    [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM]
                           (COND
                              ((AND NEAR (SETQ NEAR (MEMBER NEAR COM)))
                               (/RPLACD NEAR (CONS NAME (CDR NEAR)))
                               COM)
                              (T (MERGEINSERT NAME COM T]
                    T
                    'NOPRINT]
       ((NULL LISTNAME)                                      (* ; "add to standard com")
        [AND (NOT (MEMBER NAME (CDR COM)))
             (COND
                [(SETQ NEAR (MEMBER NEAR COM))
                 (/RPLACD NEAR (CONS NAME (CDR NEAR]
                (T (/RPLACD COM (MERGEINSERT NAME (CDR COM]
        (MARKASCHANGED COMSNAME 'VARS)
        T])

(ADDNEWCOM
  [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE)             (* rmk%: " 3-JAN-82 22:53")

    (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE.  --- if LISTNAME is given, then use it as the listname")

    (PROG (NEWCOM OLDCOM TAIL)
          (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE))
          [COND
             ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME)))
              (RETURN (SAVESET COMSNAME (LIST NEWCOM)
                             T
                             'NOPRINT]
      LP  [COND
             ((OR (NLISTP (SETQ OLDCOM (CAR TAIL)))
                  (SELECTQ (CAR OLDCOM)
                      ((LOCALVARS SPECVARS BLOCKS) 
                           T)
                      (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM)))
                      NIL))
              (/ATTACH NEWCOM TAIL))
             ((LISTP (CDR TAIL))
              (SETQ TAIL (CDR TAIL))
              (GO LP))
             (T (/RPLACD TAIL (LIST NEWCOM]
          (MARKASCHANGED COMSNAME 'VARS])

(MAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* ; "Edited  8-Apr-87 14:55 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    (PROG (TEM)

     (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname")

          (AND (LISTP NAME)
               (SETQ NAME (COPY NAME)))
          (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE))
                           (APPLY* TEM NAME TYPE LISTNAME FILE))
                      (SELECTQ TYPE
                          (PROPS [AND (NULL LISTNAME)
                                      (CONS 'PROP (CONS (COND
                                                           ((AND (LISTP (CDR NAME))
                                                                 (NULL (CDDR NAME)))
                                                            (CADR NAME))
                                                           (T (CDR NAME)))
                                                        (OR (LISTP (CAR NAME))
                                                            (LIST (CAR NAME])
                          (EXPRESSIONS [COND
                                          ((EQ (CAR NAME)
                                               'SETQ)
                                           (MAKENEWCOM (CDR NAME)
                                                  'VARS LISTNAME FILE))
                                          (T (CONS 'P (COND
                                                         (LISTNAME (LIST '* LISTNAME))
                                                         (T (LIST NAME])
                          NIL)
                      (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE])

(DEFAULTMAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* lmm "20-OCT-82 22:48")
    (COND
       ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST)
                 (fetch MACRO of TYPE)
                 (fetch GETDEF of TYPE)))
        (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION
                                                                            of TYPE)
                                                                         TYPE)
               T))
       ((NULL DEFAULTCOMHASFILEFLG)                          (* ; "disable FOOFNS FOOVARS junk")
        (LIST TYPE NAME))
       ((EQ FILE T)                                          (* ; 
                                                           "FILE=T only when called from SHOWDEF")
        (LIST TYPE NAME))
       ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE))
                                      (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME))
                                             T)
                                      T
                                      'NOPRINT]              (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items")
        (LIST TYPE '* LISTNAME))
       (T (LIST TYPE NAME])
)

(RPAQ? DEFAULTCOMHASFILEFLG )

(ADDTOVAR MARKASCHANGEDFNS )
(DEFINEQ

(MERGEINSERT
  [LAMBDA (NEW LST ONEFLG)                               (* lmm "30-Jun-86 18:11")

    (* ;; "searches LST to find the most reasonable place to insert NEW.  Does nothing if ONEFLG is T and NEW is already a member of LST")

    (COND
       ((AND ONEFLG (MEMBER NEW LST))
        LST)
       ((LISTP NEW)
        (/NCONC1 LST NEW))
       (T (PROG ((N 0)
                 LST1 PLACE TEM)
                (SETQ LST1 LST)
            LP  

           (* ;; "finds the function with the longest leading common substring.  The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.")

                (COND
                   ((NULL LST1)
                    (GO OUT))
                   ((OR (LISTP (CAR LST1))
                        (SETQ TEM (STRPOS (CAR LST1)
                                         NEW 1 NIL T T)))

                    (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE")

                    (SETQ PLACE LST1)
                    (GO OUT))
                   ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1)
                                                NEW))
                           N)
                    (SETQ N TEM)
                    (SETQ PLACE LST1)))
                (SETQ LST1 (CDR LST1))
                (GO LP)
            OUT (SETQ TEM (CAR PLACE))
                (OR [SOME (OR PLACE LST)
                          (FUNCTION (LAMBDA (X LST)
                                      (COND
                                         ([OR (ALPHORDER NEW X)
                                              (AND PLACE (NOT (ALPHORDER TEM X]

                                 (* ;; "for example, if the FNS list is something like (...  FOO FOO1 ...) where the ...  may or may not be in order, e.g.  (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.")

                                          (/ATTACH NEW LST))
                                         (T (SETQ TEM X)
                                            NIL]
                    (SETQ LST (/NCONC1 LST NEW)))
                (RETURN LST])

(MERGEINSERT1
  [LAMBDA (X Y)                                          (* rmk%: "24-MAY-82 00:05")

    (* ;; "value is the number of leading characters of X and Y that agree.")

    (PROG ((N 1)
           C1 C2)
      LP  [COND
             ((OR (NULL (SETQ C1 (NTHCHARCODE X N)))
                  (NULL (SETQ C2 (NTHCHARCODE Y N)))
                  (NEQ C1 C2))
              (RETURN (SUB1 N]
          (SETQ N (ADD1 N))
          (GO LP])
)



(* ;; 
"RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file"
)


(RPAQ ADDTOFILEKEYLST
      `(("[" "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" NOECHOFLG T)
        (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T)
        (,(CHARACTER (CHARCODE LF))
         "" EXPLAINSTRING "{line-feed} - same as previous response" NOECHOFLG T)
        (" " ,(CONCATCODES (LIST (CHARCODE SPACE)
                                 (CHARCODE EOL)))
             EXPLAINSTRING "{space} - no action" NOECHOFLG T)
        ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
             EXPLAINSTRING
             ,(CONCAT "] - nowhere, item is marked as a dummy" (CHARACTER (CHARCODE EOL)))
             NOECHOFLG T)
        ["(" "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
             (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE))
                                  ,(CHARACTER (CHARCODE EOL]
                 RETURN
                 (CDR ANSWER]
        '(@ "Near: " EXPLAINSTRING "@ other-item   -- put the item near the other item" NOECHOFLG T 
            KEYLST (( "" CONFIRMFLG (%
)
                       RETURN ANSWER)))
        [,(CHARACTER (CHARCODE CR))
         "" RETURN ,(CHARACTER (CHARCODE SPACE]
        ("" "File name: " EXPLAINSTRING "a file name" KEYLST ())))

(RPAQQ LASTFILE NIL)



(* ;; "deleting an item from a file")

(DEFINEQ

(DELFROMFILES
  [LAMBDA (NAME TYPE FILES)                              (* rmk%: " 6-MAR-82 13:16")

    (* ;; "Eliminates NAME as an item of type TYPE in COMS.")

    (PROG (COMS)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (RETURN (for FILE inside (OR FILES FILELST)
                     when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE))
                                            NAME TYPE)
                                  (COND
                                     ((INFILECOMS? NAME TYPE COMS)
                                      (printout T "(could not delete " NAME " from " FILE ")" T))))
                     collect (for FN in (fetch WHENUNFILED of TYPE)
                                    do (APPLY* FN NAME TYPE FILE))
                           FILE])

(DELFROMCOMS
  [LAMBDA (COMS NAME TYPE)                               (* bvm%: " 1-Oct-86 22:02")

    (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list).  Returns T if it does anything")

    (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.")

    (COND
       [(LITATOM COMS)
        (LET ((COMSNAME COMS))
             (DECLARE (SPECVARS COMS))
             (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME)))
                  (DELFROMCOMS COMS NAME TYPE]
       (T (PROG (DONE)
                (SETQ TYPE (GETFILEPKGTYPE TYPE))
            LP  (COND
                   ((NLISTP COMS)
                    (RETURN DONE)))
                [COND
                   ((LISTP (CAR COMS))
                    (SELECTQ (DELFROMCOM (CAR COMS)
                                    NAME TYPE)
                        (ALL (/RPLNODE2 COMS (CDR COMS))
                             (SETQQ DONE ALL)
                             (GO LP))
                        (NIL)
                        (SETQ DONE T)))
                   (T (SELECTQ (CAR COMS)
                          ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                               (SETQ COMS (CDR COMS)))
                          (COND
                             ((AND (EQ TYPE 'VARS)
                                   (EQ NAME (CAR COMS)))
                              (/RPLNODE2 COMS (CDR COMS))
                              (SETQ DONE T)
                              (GO LP]
                (SETQ COMS (CDR COMS))
                (GO LP])

(DELFROMCOM
  [LAMBDA (COM NAME TYPE)                                (* ; "Edited  2-May-87 19:02 by Pavel")
                                                             (* ; "Tries to delete NAME from COM")
    (PROG (TEM VAR NEW)
          (COND
             ((SETQ TEM (fetch DELETE of (CAR COM)))
              (AND (SETQ TEM (APPLY* TEM COM NAME TYPE))
                   (MARKASCHANGED COMSNAME 'VARS))
              (RETURN TEM)))
          (RETURN (SELECTQ (CAR COM)
                      ((DECLARE%: COMS) 
                           (DELFROMCOMS (COND
                                               [(EQ (CADR COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CADDR COM))
                                                    (CADDR COM))
                                                   (T (RETURN]
                                               (T (CDR COM)))
                                  NAME TYPE))
                      ((CL:EVAL-WHEN) 
                           (DELFROMCOMS (COND
                                               [(EQ (CL:THIRD COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CL:FOURTH COM))
                                                    (CL:FOURTH COM))
                                                   (T (RETURN]
                                               (T (CDDR COM)))
                                  NAME TYPE))
                      ((ALISTS PROPS) 
                           (AND (EQ TYPE (CAR COM))
                                (COND
                                   ((EQ (CADR COM)
                                        '*)
                                    (COND
                                       ([AND (LITATOM (SETQ VAR (CADDR COM)))
                                             (SETQ TEM (ASSOC (CAR NAME)
                                                              (GETTOPVAL VAR)))
                                             (NEQ (CDR TEM)
                                                  (SETQ TEM (REMOVEITEM (CADR NAME)
                                                                   (CDR TEM]
                                        (SAVESET VAR TEM T 'NOPRINT)
                                        T)))
                                   ([AND [CDR (SETQ TEM (ASSOC (CAR NAME)
                                                               (CDR COM]
                                         (NEQ (CDR TEM)
                                              (SETQ NEW (REMOVEITEM (CADR NAME)
                                                               (CDR TEM]
                                    (/RPLACD TEM NEW)
                                    (MARKASCHANGED COMSNAME 'VARS)
                                    T))))
                      (BLOCKS 
                              (* ;; "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")

                              [AND (EQ TYPE 'FNS)
                                   (for BLOCK in (INFILECOMTAIL COM T)
                                      do (AND (MEMB NAME BLOCK)
                                                  (/DREMOVE NAME BLOCK))
                                            (for X in BLOCK
                                               when (AND (LISTP X)
                                                             (MEMB NAME (CDR X)))
                                               do (/RPLACD X (REMOVE NAME (CDR X])
                      ((PROP IFPROP) 
                           [SELECTQ TYPE
                               (PROPS (RETURN (COND
                                                 ((EQ (CADR COM)
                                                      (CADR NAME))
                                                  (DELFROMCOM1 (CDR COM)
                                                         (CAR NAME)))
                                                 ((AND (EQMEMB (CADR NAME)
                                                              (CADR COM))
                                                       [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM]
                                                       (EQ (CAR TEM)
                                                           (CAR NAME)))
                                                  [/RPLACA (CDR COM)
                                                         (REMOVE (CADR NAME)
                                                                (MKLIST (CADR COM]
                                                  (MARKASCHANGED COMSNAME 'VARS)
                                                  T))))
                               (COND
                                  ([for PROP inside (CADR COM)
                                      always (EQ TYPE (GETPROP PROP 'PROPTYPE]
                                   (DELFROMCOM1 (CDR COM)
                                          NAME])
                      ((RECORDS INITRECORDS SYSRECORDS) 
                           (AND (EQ TYPE 'RECORDS)
                                (DELFROMCOM1 COM NAME)))
                      (P (AND (EQ TYPE 'EXPRESSIONS)
                              (DELFROMCOM1 COM NAME)))
                      ((VARS INITVARS) 
                           (AND (EQ TYPE 'VARS)
                                (DELFROMCOM1 COM NAME T)))
                      (AND (EQ TYPE (CAR COM))
                           (DELFROMCOM1 COM NAME])

(DELFROMCOM1
  [LAMBDA (COM NAME FLG)                                 (* rmk%: "10-JUN-82 22:44")

    (* ;; 
  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed")

    (LET (TEM VAL)
         (COND
            ((EQ (CADR COM)
                 '*)
             (COND
                ([AND (LITATOM (SETQ TEM (CADDR COM)))
                      (NEQ (SETQ VAL (GETTOPVAL TEM))
                           (SETQ VAL (REMOVEITEM NAME VAL FLG]
                 (SAVESET TEM VAL T 'NOPRINT)
                 T)))
            ((NEQ (CDR COM)
                  (SETQ TEM (REMOVEITEM NAME (CDR COM)
                                   FLG)))
             (/RPLACD COM TEM)
             (MARKASCHANGED COMSNAME 'VARS)
             T])

(REMOVEITEM
  [LAMBDA (X LST FLG)                                    (* ; "Edited 25-May-88 17:52 by drc:")
                                                             (* lmm "10-FEB-78 17:29")

    (* ;; 
  "returns a subset of LST with X deleted;  if FLG is set, also remove elements whose CAR is X")

    (COND
       [[OR (MEMBER X LST)
            (AND FLG (SOME LST (FUNCTION (LAMBDA (Y)
                                           (EQUAL (CAR (LISTP Y))
                                                  X]
        (SUBSET LST (FUNCTION (LAMBDA (Y)
                                (AND (NOT (EQUAL Y X))
                                     (OR (NOT FLG)
                                         (NLISTP Y)
                                         (NOT (EQUAL (CAR Y)
                                                     X]
       (T LST])

(MOVETOFILE
  [LAMBDA (TOFILE NAME TYPE FROMFILE)                    (* rmk%: "18-OCT-79 19:51")
                                                             (* ; "To move items between files")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    [COND
       ((OR (EQ TYPE 'FNS)
            FROMFILE)                                        (* ; 
       "FNS definition can reside on file if LOADFNS was done.  This guarantees that it is loaded.")
        (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM]
    (AND (EQ TYPE 'FNS)
         (MARKASCHANGED NAME TYPE))                      (* ; 
                                                   "FNS won't get dumped unless they are `changed'")
    (DELFROMFILES NAME TYPE FROMFILE)
    (ADDTOFILE NAME TYPE TOFILE])
)

(MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)

(MOVD? 'MOVETOFILE 'MOVEITEM NIL T)

(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)



(* ; "functions for doing things and marking them changed and auxiliary functions")

(DEFINEQ

(SAVEPUT
  [LAMBDA (ATM PROP VAL)                                 (* lmm " 7-May-84 16:56")

    (* ;; "analogous to SAVESET but also marks changed property lists;  LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT")

    [COND
       ((NOT (LITATOM ATM))
        (ERRORX (LIST 14 ATM]
    (PROG ((X (GETPROPLIST ATM))
           X0 TEM OLDFLG)
      LOOP
          (COND
             ((NLISTP X)
              (COND
                 ((AND (NULL X)
                       X0)                                   (* ; 
                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")
                  (SETQ TEM (LIST PROP VAL))
                  (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                        LISPXHIST))
                  (FRPLACD (CDR X0)
                         TEM)
                  (GO RET)))

              (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")

              )
             ((NLISTP (CDR X))

              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning.")

              )
             [(EQ (CAR X)
                  PROP)
              (SETQ OLDFLG (NEQ (EQUALN (CADR X)
                                       VAL 400)
                                T))                          (* ; "i.e. it probably changed")
              (/RPLACA (CDR X)
                     VAL)
              (COND
                 ((NOT OLDFLG)
                  (GO RET1))
                 (T (OR (EQ DFNFLG T)
                        (LISPXPRINT (LIST 'new PROP 'property 'for ATM)
                               T T))
                    (GO RET]
             (T (SETQ X (CDDR (SETQ X0 X)))
                (GO LOOP)))
          [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM]
          (SETPROPLIST ATM TEM)
          (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                LISPXHIST))
      RET (MARKASCHANGED (LIST ATM PROP)
                 'PROPS
                 (NOT OLDFLG))
      RET1
          (AND ADDSPELLFLG (ADDSPELL ATM 0))
          (RETURN VAL])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
    (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT))
)
(DEFINEQ

(UNMARKASCHANGED
  [LAMBDA (NAME TYPE)                                    (* JonL "24-Jul-84 19:59")

    (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties.  Value is name if anything is done")

    (PROG (ANYFLG)
          (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE
                                                                          TYPE
                                                                          'TYPE]
             while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL)
                                                               (SETQ ANYFLG T))
          [for F TAIL PROP TYPEDPROP in FILELST
             when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP
                                                    (ASSOC TYPE (fetch TOBEDUMPED
                                                                   of (SETQ PROP
                                                                           (fetch FILEPROP
                                                                              of F]
             do (SETQ ANYFLG T)
                   (COND
                      ((SETQ TAIL (REMOVE (CAR TAIL)
                                         (CDR TYPEDPROP)))
                       (/RPLACD TYPEDPROP TAIL))
                      (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP
                                                                              (fetch TOBEDUMPED
                                                                                 of PROP]
          (RETURN (AND ANYFLG NAME])

(PREEDITFN
  [LAMBDA (ATM TYPE EDITCHANGES)                         (* rmk%: "18-FEB-82 21:49")
                                                             (* ; 
                                           "EDITL is advised to call this before editing something")
    (AND FILEPKGFLG (SELECTQ TYPE
                        (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                   (CONS))
                                                            CLISPARRAY))
                                      (for X in (GETPROPLIST ATM)
                                         do (OR (NLISTP X)
                                                    (GETHASH X CLISPARRAY)
                                                    (PUTHASH X (CONS (CAR X)
                                                                     (CDR X))
                                                           CLISPARRAY]

                                 (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made")

                                 [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS)
                                                      EDITCHANGES
                                                      (APPEND (GETPROPLIST ATM])
                        (VARS [COND
                                 ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE))
                                  [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                    (CONS))
                                                             CLISPARRAY))
                                       (for X in (EVALV ATM)
                                          do (OR (NLISTP X)
                                                     (GETHASH X CLISPARRAY)
                                                     (PUTHASH X (CONS (CAR X)
                                                                      (CDR X))
                                                            CLISPARRAY]
                                  (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS)
                                                       EDITCHANGES
                                                       (for X in (EVALV ATM)
                                                          collect (CAR X])
                        NIL])

(POSTEDITPROPS
  [LAMBDA (EDITCHANGES OLDPROPS)                         (* rmk%: "18-FEB-82 21:50")
                                                             (* ; "was RESETSAVE'd from PREEDITFN")
    (PROG (OV FOUNDCHANGE)
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP)
                 when (for OLDPROP on OLDPROPS by (CDDR OLDPROP)
                             do (COND
                                       ((EQ (CAR OLDPROP)
                                            (CAR NEWPROP))   (* ; "Found the property")
                                        [AND (EQ (CADR OLDPROP)
                                                 (CADR NEWPROP))
                                             (COND
                                                ((NLISTP (CADR OLDPROP))
                                                             (* ; "value is same")
                                                 (RETURN))
                                                ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP)
                                                                                 CLISPARRAY))
                                                      (EQ (CAADR NEWPROP)
                                                          (CAR OV))
                                                      (EQ (CDADR NEWPROP)
                                                          (CDR OV)))
                                                 (PUTHASH (CADR NEWPROP)
                                                        NIL CLISPARRAY)
                                                             (* ; 
                                         "value has been edited (CLISPARRAY translation went away)")
                                                 (RETURN]
                                        (RETURN T))) finally 
                                                             (* ; "didn't find the property")
                                                           (RETURN T))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 (CAR NEWPROP))
                               'PROPS NIL)
                       (SETQ FOUNDCHANGE T))
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])

(POSTEDITALISTS
  [LAMBDA (EDITCHANGES OLDTOKENS)                        (* rmk%: " 4-JAN-82 10:14")
    (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES]
                                                             (* ; 
                                                           "called after an ALIST has been edited")
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 X)
                               'ALISTS NIL)
                       (SETQ FOUNDCHANGE T))
              [for NEWENTRY in NEWENTRIES
                 do (COND
                           ([AND (LISTP NEWENTRY)
                                 (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY))
                                           (EQ (CAR NEWENTRY)
                                               (CAR OV))
                                           (EQ (CDR NEWENTRY)
                                               (CDR OV]
                            (PUTHASH NEWENTRY NIL CLISPARRAY)
                            (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                     (CAR NEWENTRY))
                                   'ALISTS NIL)
                            (SETQ FOUNDCHANGE T]
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])
)

(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
                       (PUTPROP . SAVEPUT))



(* ; "sub-functions for file package commands & types")

(DEFINEQ

(ALISTS.GETDEF
  [LAMBDA (NAME TYPE OPTIONS)                            (* Pavel " 7-Oct-86 17:24")
    (AND (LISTP NAME)
         (CL:SYMBOLP (CAR NAME))
         (LET [(ASSOCIATION (ASSOC (CADR NAME)
                                   (GETTOPVAL (CAR NAME]
              (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME)
                                     ASSOCIATION])

(ALISTS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm "16-OCT-78 20:02")
                                                             (* ; 
                                          "called by MARKASCHANGED when an ALIST entry has changed")
    (PROG [(VARTYPE (GETPROP (CAR NAME)
                           'VARTYPE]
          (AND (LISTP VARTYPE)
               (EQ (CAR VARTYPE)
                   'ALIST)
               (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME)
                                              (CADR VARTYPE)
                                              NEWFLG])

(CLEARCLISPARRAY
  [LAMBDA (NAME TYPE REASON)
    (DECLARE (SPECVARS NAME TYPE REASON))            (* lmm "14-Aug-84 15:03")
    (AND CLISPARRAY (MAPHASH CLISPARRAY (COND
                                           [(EQ TYPE 'I.S.OPRS)
                                            (FUNCTION (LAMBDA (TRAN FORM)
                                                        (AND (MEMB NAME FORM)
                                                             (PUTHASH FORM NIL CLISPARRAY]
                                           (T                (* ; "MACRO changed")
                                              (FUNCTION (LAMBDA (TRAN FORM)
                                                          (COND
                                                             ((OR (EQ NAME (CAR FORM))
                                                                  (EQ (CAR (GETPROP (CAR FORM)
                                                                                  'CLISPWORD))
                                                                      'CHANGETRAN))
                                                              (PUTHASH FORM NIL CLISPARRAY])

(EXPRESSIONS.WHENCHANGED
  [LAMBDA (EXPR)                                         (* ; "Edited  6-Apr-87 20:21 by Pavel")
    (SELECTQ (CAR EXPR)
        ((SETQ SETQQ) 
             (UNMARKASCHANGED (CADR EXPR)
                    'VARS))
        ((PROGN PROG) 
             (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X)))
        NIL])

(MAKEALISTCOMS
  [NLAMBDA X                                             (* rmk%: "14-OCT-83 13:34")

    (* ;; "make command to dump prettydefmacros")

    (LIST
     (CONS 'ADDVARS
           (for PR in X
              join (for ALISTNAME inside (CAR PR)
                          collect (CONS ALISTNAME
                                            (for ATNAME inside (CDR PR) bind ENTRY
                                               when (SETQ ENTRY
                                                         (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME))
                                                             (PROGN (LISPXPRINT (LIST 'no ATNAME
                                                                                      'entry
                                                                                      'on ALISTNAME)
                                                                           T T)
                                                                    NIL))) collect ENTRY])

(MAKEFILESCOMS
  [NLAMBDA FILES                                         (* JonL "12-FEB-83 19:02")

    (* ;; "This scans the command just to warn the user about any errors.  Must match up with the big SELECTQ in FILESLOAD NIL")

    [for FILE in FILES
       do
       (OR
        (LITATOM FILE)
        (while (LISTP FILE)
           do (SELECTQ (CAR (OR (LISTP FILE)
                                    (RETURN)))
                      ((LOADCOMP LOADFROM))
                      (FROM (pop FILE)
                            (if (OR (EQ (CAR FILE)
                                            'VALUEOF)
                                        (if (AND (EQ (CAR FILE)
                                                         'VALUE)
                                                     (EQ (CADR FILE)
                                                         'OF))
                                            then (pop FILE)))
                                then (pop FILE)))
                      ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR))
                      (OR (FMEMB (CAR FILE)
                                 LOADOPTIONS)
                          (PRINT (CONS (CAR FILE)
                                       '(-- unrecognized FILES option))
                                 T)))
                 (pop FILE]
    (CONS 'FILESLOAD FILES])

(MAKELISPXMACROSCOMS
  [NLAMBDA X                                             (* lmm " 5-SEP-78 23:15")
    (PROG (TEM TEM2)
          (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                   LISPXHISTORYMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXHISTORYMACROS TEM)))
                                                       (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                          LISPXMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXMACROS TEM]
                        (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z LISPXCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2]
                                          (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z HISTORYCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2])

(MAKEPROPSCOMS
  [NLAMBDA X                                             (* lmm "26-FEB-78 17:10")

    (* ;; "make command to dump PROPS")

    (for PAIR in X collect (CONS 'PROP (CONS (COND
                                                            ((AND (LISTP (CDR PAIR))
                                                                  (NULL (CDDR PAIR)))
                                                             (CADR PAIR))
                                                            (T (CDR PAIR)))
                                                         (OR (LISTP (CAR PAIR))
                                                             (LIST (CAR PAIR])

(MAKEUSERMACROSCOMS
  [NLAMBDA X                                             (* rmk%: " 3-JAN-82 23:20")
    (PROG (TEM)
          [COND
             [X (for Y in X
                   do (OR (FASSOC Y USERMACROS)
                              (FASSOC Y EDITMACROS)
                              (LISPXPRINT (CONS Y '(-- no entry on USERMACROS))
                                     T T]
             (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR))
                               X]
          (RETURN (LIST (CONS 'ADDVARS
                              (NCONC (for VAR in '(USERMACROS EDITMACROS)
                                        when (SETQ TEM (for Y in (GETTOPVAL VAR)
                                                              when (FMEMB (CAR Y)
                                                                              X) collect Y))
                                        collect (CONS VAR TEM))
                                     (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS 
                                                                 DONTSAVEHISTORYCOMS)
                                        when [SETQ TEM
                                                  (SUBSET (GETTOPVAL LST)
                                                         (FUNCTION (LAMBDA (Y)
                                                                     (OR (FMEMB Y X)
                                                                         (AND (LISTP Y)
                                                                              (FMEMB (CAR Y)
                                                                                     X]
                                        collect (CONS LST TEM])

(PROPS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm " 7-SEP-78 22:08")
    (PROG [(PROPTYPE (GETPROP (CADR NAME)
                            'PROPTYPE]
          (COND
             [PROPTYPE (RETFROM 'MARKASCHANGED (COND
                                                  ((NEQ PROPTYPE 'IGNORE)
                                                   (MARKASCHANGED (CAR NAME)
                                                          PROPTYPE NEWFLG]
             (T (SELECTQ (CADR NAME)
                    (CLISPWORD (CLEARCLISPARRAY (CAR NAME)))
                    NIL])

(FILEGETDEF.LISPXMACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:12")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (EQ FIRST 'ADDTOVAR)
                                                                   (MEMB SECOND '(LISPXMACROS 
                                                                                        LISPXCOMS))
                                                                   T]
                when (SELECTQ (CADR X)
                             (LISPXMACROS                    (* ; 
                      "Rebuild the expressions cause there might be other elements in the ADDTOVAR")
                                          (AND (SETQ X (ASSOC NAME (CDDR X)))
                                               (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X))))
                             (LISPXCOMS [COND
                                           ((MEMB NAME (CDDR X))
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME)))
                                           ((SETQ X (ASSOC NAME (CDDR X)))
                                                             (* ; "For synonym pairs")
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X])
                             NIL) collect X])

(FILEGETDEF.ALISTS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'ADDTOVAR)
                                                          (EQ SECOND (CAR NAME]
       when (SETQ X (ASSOC (CADR NAME)
                               (CDDR X))) collect X
       finally (RETURN (COND
                              ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.RECORDS
  [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND)            (* lmm "26-Jun-86 15:56")
    (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                              (AND (MEMB FIRST CLISPRECORDTYPES)
                                                   (OR (EQ SECOND NAME)
                                                       (AND (MEMB SECOND '(%( %[))
                                                            (PROGN (RATOM)
                                                                   (RATOM)
                                                                   (RATOM)
                                                                   (EQ NAME (RATOM]
         (if (EQ (CAAR VAL)
                     'NOT-FOUND%:)
             then NOTFOUND
           elseif (CDR VAL)
             then (CONS 'PROGN VAL)
           else (CAR VAL])

(FILEGETDEF.PROPS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'PUTPROPS)
                                                          (EQ SECOND (CAR NAME]
       join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL)
                                                                              (CADR NAME))
                   join (LIST (CAR TAIL)
                                  (CADR TAIL)))
       finally (RETURN (COND
                              ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.MACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "28-May-86 09:51")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (FMEMB FIRST '(PUTPROPS DEFMACRO))
                                                                   (EQ SECOND NAME]
                join (if (EQ (CAR X)
                                     'DEFMACRO)
                             then (LIST X)
                           else (for TAIL on (CDDR X) by (CDDR TAIL)
                                       when (FMEMB (CAR TAIL)
                                                       MACROPROPS) collect (LIST 'PUTPROPS
                                                                                     (CADR X)
                                                                                     (CAR TAIL)
                                                                                     (CADR TAIL])

(FILEGETDEF.VARS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:14")
    (for X in (LOADFNS NIL SOURCE 'GETDEF NAME)
       do (SELECTQ (CAR X)
                  ((RPAQQ SETQQ) 
                       (RETURN (CADDR X)))
                  ((RPAQ SETQ RPAQ?) 
                       (RETURN (EVAL (CADDR X))))
                  NIL) finally (RETURN 'NOBIND])

(FILEGETDEF.FNS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: "29-Aug-86 22:30")
    (LET (MAP ENV)
         (COND
            [(AND (EQMEMB 'FAST OPTIONS)
                  (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
                                (GET-ENVIRONMENT-AND-FILEMAP SOURCE))
                         MAP))
             (for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME
                                                                                      (CDDR PAIR]
                do [OR (OPENP SOURCE)
                           (RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
                                                                             'OLD]
                      (SETFILEPTR SOURCE MAPLOC)
                      (RETURN (WITH-READER-ENVIRONMENT ENV
                                  [COND
                                     ((EQMEMB 'ARGLIST OPTIONS)
                                      (RATOM SOURCE)
                                      (READ SOURCE)
                                      (RATOM SOURCE)
                                      (LIST (READ SOURCE)
                                            (READ SOURCE)))
                                     (T (CADR (READ SOURCE])]
            (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])

(FILEPKGCOMS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 11:29")
    (PROG (COM TYP)
          [SELECTQ (CAR (LISTP DEFINITION))
              (COM (SETQ COM (CDR DEFINITION)))
              (TYPE (SETQ TYP (CDR DEFINITION)))
              (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION)))
                     (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION]

     (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE")

          (for I in COM by (CDDR I) do (SELECTQ I
                                                           ((ADD DELETE MACRO CONTENTS CONTAIN COM))
                                                           (ERROR I 
                                                                  "not file package command property"
                                                                  )))
                                                             (* ; 
                                                   "COM merely adds to spelling list, for builtins")
          [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS)
                                             (LISTGET COM 'CONTAIN]
                                                             (* ; "Until CONTAIN is de-documented.")
          (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP
                                                                         (LISTGET COM PROP)))
          [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS)
                                                           (SELECTQ I
                                                               ((DESCRIPTION TYPE))
                                                               (ERROR I 
                                                             "not file package type/command property"
                                                                      ]
                                                             (* ; 
                                                  "TYPE merely adds to spelling list, for builtins")
          (for PROP in (UNION '(DESCRIPTION TYPE)
                                      FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP
                                                                      (LISTGET TYP PROP])

(FILES.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 17:13")
    (PROGN (PUTDEF (FILECOMS NAME)
                  'VARS
                  (CAR DEFINITION)
                  REASON)                                    (* ; "DEFINE THE COMS")
           (ADDFILE NAME)                                (* ; 
                                                           "MAKE SURE IT IS A FILE PACKAGE ENTITY")
           [/replace TOBEDUMPED of (fetch FILEPROP of NAME)
                                          (FILEPKG.MERGECHANGES (CADR DEFINITION)
                                                 (fetch TOBEDUMPED of (fetch FILEPROP
                                                                                 of NAME]
           (OR (fetch FILEDATES of NAME)
               (/replace FILEDATES of NAME with (CADDR DEFINITION])

(VARS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "29-Jul-85 20:59")
    (/SETTOPVAL NAME DEFINITION T])

(FILES.WHENCHANGED
  [LAMBDA (NAME TYPE REASON)
    (MARKASCHANGED (FILECOMS NAME)
           'VARS REASON])
)

(ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO)

(ADDTOVAR SYSPROPS PROPTYPE)

(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)

(PUTPROPS SUBR PROPTYPE IGNORE)

(PUTPROPS LIST PROPTYPE IGNORE)

(PUTPROPS CODE PROPTYPE IGNORE)

(PUTPROPS FILEDATES PROPTYPE IGNORE)

(PUTPROPS FILE PROPTYPE IGNORE)

(PUTPROPS FILEMAP PROPTYPE IGNORE)

(PUTPROPS EXPR PROPTYPE FNS)

(PUTPROPS VALUE PROPTYPE VARS)

(PUTPROPS COPYRIGHT PROPTYPE FILES)

(PUTPROPS FILETYPE PROPTYPE FILES)

(PUTPROPS BAKTRACELST VARTYPE ALIST)

(PUTPROPS BREAKMACROS VARTYPE ALIST)

(PUTPROPS COMPILETYPELST VARTYPE ALIST)

(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))

(PUTPROPS ERRORTYPELST VARTYPE ALIST)

(PUTPROPS FONTDEFS VARTYPE ALIST)

(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))

(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)

(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)

(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)

(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))



(* ; "Define the commands below AFTER the various properties have been established.")


(ADDTOVAR USERMACROS
          (M NIL (MAKE FILE FILE))
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITMACROS
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITCOMSA M)

(ADDTOVAR EDITCOMSL M)



(* ; "GETDEF methods")

(DEFINEQ

(RENAME
  [LAMBDA (OLD NEW TYPES FILES METHOD)               (* JonL "24-Jul-84 20:01")
    (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD)))

     (* ;; "special kludge: change the callers BEFORE if we are changing a field;  this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message")

          [for TYPE inside TYPES when (NEQ TYPE 'FIELDS)
             do (COPYDEF OLD NEW TYPE NIL (COND
                                                     ((EQ TYPE 'VARS)
                                                      'NOERROR]
          (CHANGECALLERS OLD NEW TYPES FILES METHOD)
          [for TYPE inside TYPES do (COND
                                                   ((AND (EQ TYPE 'FIELDS)
                                                         (HASDEF OLD 'FIELDS))

                                 (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file.  Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.")

                                                    (COPYDEF OLD NEW 'FIELDS))
                                                   (T (DELDEF OLD TYPE]
          (RETURN NEW])

(CHANGECALLERS
  [LAMBDA (OLD NEW AS-TYPES FILES METHOD)            (* ; "Edited  6-Dec-86 01:25 by lmm")
    (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES))
           REL TEM EDITCOMS FNS)
          (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD))
          [SETQ EDITCOMS
           (LIST (COND
                    [(OR (EQMEMB 'CAREFUL METHOD)
                         (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES))
                                (printout T "Warning --" OLD " is also defined as " TEM T)))

                     (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename.  Y means do it, No means skip, anything else goes into TTY.")

                     (SUBPAIR '(OLD NEW)
                            (LIST OLD NEW)
                            '(BIND (LPQ (F OLD N)
                                            (MARK %#1)
                                            (ORR (1 !0 P)
                                                 NIL)
                                            (MARK %#2)
                                            (COMS (SELECTQ (ASKUSER NIL NIL "   Replace ? "
                                                                  '((Y "Yes
")
                                                                    (N "No
")
                                                                    (%
 "")
                                                                    (%  "")
                                                                    (%
 "")
                                                                    (& ""))
                                                                  NIL NIL '(NOECHOFLG T))
                                                      (Y '(R1 OLD NEW))
                                                      (N NIL)
                                                      'TTY%:))
                                            (MARK %#3)
                                            (IF (EQ (%## (\ %#3))
                                                        (%## (\ %#2)))
                                                   ((\ %#1))
                                                   NIL]
                    (T (LIST 'R OLD NEW]
          (SELECTQ (COND
                      ((AND (EQMEMB 'MASTERSCOPE METHOD)
                            MSDATABASELST
                            (for TYPE inside AS-TYPES
                               do [COND
                                         ((SETQ TEM (SELECTQ TYPE
                                                        ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 
                                                             'CALL)
                                                        (MACROS '(CALL DIRECTLY))
                                                        ((VARS VARIABLES) 
                                                             '(USE OR BIND))
                                                        ((RECORDS FIELDS I.S.OPRS) 
                                                             (LIST 'USE 'AS TYPE))
                                                        (RETURN NIL)))
                                          (COND
                                             (REL (SETQ REL (LIST TEM 'OR REL)))
                                             (T (SETQ REL TEM] FINALLY (RETURN REL)))

                       (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known")

                       'MASTERSCOPE)
                      ((EQMEMB 'EDITCALLERS METHOD)
                       'EDITCALLERS)
                      (T 'SEARCH))
              (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND
                                                     ((NULL FILES)
                                                      (UPDATEFILES)
                                                      (FILEPKGCHANGES 'FNS]
                                                  (for FILE inside (OR FILES FILELST)
                                                     join (FILEFNSLST FILE]
                                 (FUNCTION UPDATEFN))
                           (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL))
                                                          T)
                                            FNS)))
              (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST)
                                          when (SETQ TEM (EDITCALLERS OLD X T))
                                          collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM)))
                                                             X))))
              (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST
                                                                                   X))))
              (ERROR "UNRECOGNIZED RENAME METHOD" METHOD))
          (AND (EQMEMB 'FNS AS-TYPES)
               (FMEMB OLD FNS)
               (SETQ FNS (REMOVE OLD FNS)))
          (EDITFROMFILE FNS FILES OLD EDITCOMS)
          [for TYPE inside AS-TYPES
             do (for FILE in (WHEREIS OLD TYPE FILES)
                       do (AND (ADDTOFILE NEW TYPE FILE)
                                   (DELFROMFILES OLD TYPE FILE)
                                   (printout T OLD " changed to " NEW " on " FILE)))
                   (COND
                      ((SETQ TEM (WHEREIS OLD TYPE FILES))
                       (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM]
          (COND
             (REL (UPDATECHANGED)
                  (COND
                     ((AND (SETQ TEM (GETRELATION OLD REL T))
                           (WHEREIS TEM 'FNS FILES))
                      (printout T "Couldn't find where " OLD " is referenced in " TEM T])
)
(DEFINEQ

(SHOWDEF
  [LAMBDA (NAME TYPE FILE)                              (* ; "Edited 16-Apr-2018 21:35 by rmk:")
                                                             (* ; 
                                                 "prettyprint NAME as it would be dumped as a TYPE")
    (RESETLST
        (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
              (DECLARE (SPECVARS . T))
              [AND FILE (NEQ FILE (OUTPUT))
                   (if (SETQ FL (OPENP FILE 'OUTPUT))
                       then (RESETSAVE (OUTPUT FL))
                     else (OUTFILE FILE)
                           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                                (OUTPUT]
              (PRETTYCOM (MAKENEWCOM NAME TYPE))))])

(COPYDEF
  [LAMBDA (OLD NEW TYPE SOURCE OPTIONS)              (* lmm "14-Aug-84 18:38")
                                                             (* ; "like MOVD, but takes a type.")
    (PROG (TEM DEF)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          [SETQ DEF (GETDEF OLD TYPE SOURCE (COND
                                                   ((EQ OPTIONS 'NOCOPY)
                                                    NIL)
                                                   (T (REMOVE 'NOCOPY (MKLIST OPTIONS]
                                                             (* ; 
      "The default is for GETDEF to return a COPY.  Make sure that NOCOPY isn't in options though.")
          (SELECTQ TYPE
              (VARS)
              (FILES [for X in (CAR DEF)
                        do                               (* ; 
                                          "change all the listnames which are of form filenameTYPE")
                              (SELECTQ (CAR X)
                                  ((PROP IFPROP) 
                                       (SETQ X (CDR X)))
                                  NIL)
                              (COND
                                 ((EQ (CADR X)
                                      '*)
                                  (SETQ X (CDDR X))
                                  (COND
                                     ((AND (LITATOM (CAR X))
                                           (SETQ TEM (STRPOS OLD (CAR X)
                                                            1 NIL T T)))
                                      (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X)
                                                                           TEM -1)))
                                             (COPY (GETTOPVAL (CAR X)))
                                             T)
                                      (FRPLACA X TEM])
              ((PROPS ALISTS) 
                   (OR (EQ (CAR NEW)
                           (CAR OLD))
                       (DSUBST (CAR NEW)
                              (CAR OLD)
                              DEF))
                   (OR (EQ (CADR NEW)
                           (CADR OLD))
                       (DSUBST (CADR NEW)
                              (CADR OLD)
                              DEF)))
              (DSUBST NEW OLD DEF))
          (PUTDEF NEW TYPE DEF)
          (RETURN NEW])

(GETDEF
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "13-Jul-85 04:10")

    (* ;; "returns the definition of NAME as a TYPE from SOURCE;  cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found.  The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.")

    (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS)))
          (DECLARE (SPECVARS NOCOPY))
          (SELECTQ OPTIONS
              (0 (SETQQ OPTIONS (NOERROR NODWIM))
                 (SETQ NOCOPY T))
              (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST))
                 (SETQ NOCOPY T))
              (T (SETQQ OPTIONS SPELL))
              NIL)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          (SELECTQ SOURCE
              (0 (SETQQ SOURCE CURRENT))
              (T (SETQQ SOURCE SAVED))
              (NIL (SETQQ SOURCE ?))
              NIL)
          [SELECTQ SOURCE
              (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS)))
              (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS]
                      (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS])
              (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS)))
              (COND
                 ((AND (LISTP SOURCE)
                       (EQ (CAR SOURCE)
                           '=))
                  (SETQ DEF (CDR SOURCE)))
                 (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS))
                    (SETQ NOCOPY T]
          (OR NOCOPY (SETQ DEF (COPY DEF)))
          (COND
             ((AND (EQ TYPE 'FNS)
                   (NOT (EQMEMB 'NODWIM OPTIONS)))
              (DWIMDEF DEF NAME SOURCE)))
          (RETURN DEF])

(GETDEFCOM
  [LAMBDA (X)                                            (* lmm " 4-Jul-85 13:31")

    (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in.  Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed.  --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.  That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.")
                                                             (* ; "a RETFROM point")
    (for Y in X join (GETDEFCOM0 Y])

(GETDEFCOM0
  [LAMBDA (COM)                                          (* wt%: " 7-FEB-79 23:28")
    (PROG (TEM)
          (RETURN (COND
                     ((SETQ TEM (fetch MACRO of (CAR COM)))
                                                             (* COND ((fetch CONTENTS of
                                                           (CAR COM)) (* ; 
                        "if it has a CONTENTS function, generally means it is not safe to evaluate")
                                                           (RETFROM (QUOTE GETDEFCOM))))
                      (for Y in (SUBPAIR (CAR TEM)
                                               (PRETTYCOM1 COM)
                                               (CDR TEM)) join (GETDEFCOM0 Y)))
                     (T (SELECTQ (CAR COM)
                            (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X)))
                            (ADDVARS (for Y in (PRETTYCOM1 COM)
                                        collect (CONS 'ADDTOVAR Y)))
                            (APPENDVARS (for Y in (PRETTYCOM1 COM)
                                           collect (CONS 'APPENDTOVAR Y)))
                            (P (APPEND (PRETTYCOM1 COM)))
                            (RETFROM 'GETDEFCOM])

(GETDEFCURRENT
  [LAMBDA (NAME TYPE OPTIONS)                            (* ; "Edited  2-May-87 19:00 by Pavel")
                                                             (* ; 
                                                           "Gets the current definition--source=0")
    (LET
     (DEF)
     (COND
        ((AND (SETQ DEF (fetch GETDEF of TYPE))
              (NEQ DEF T))

         (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")

         (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS))
                  (fetch NULLDEF of TYPE))
             (GETDEFERR NAME TYPE OPTIONS))
         DEF)
        (T
         (OR
          (NEQ
           [SETQ DEF
            (SELECTQ TYPE
                (FNS (AND (LITATOM NAME)
                          (EXPRP (SETQ DEF (VIRGINFN NAME)))
                          DEF))
                (VARS (if (LITATOM NAME)
                          then (GETTOPVAL NAME)
                        else 'NOBIND))
                ((FIELDS RECORDS) 
                     (if (LITATOM NAME)
                         then [SETQ DEF (SELECTQ TYPE
                                                (RECORDS (RECLOOK NAME))
                                                (MKPROGN (FIELDLOOK NAME]
                               (if (EQMEMB 'EDIT OPTIONS)
                                   then (COPY DEF)
                                 else DEF)))
                (FILES                                       (* ; 
              "what is the `definition' of a file?  -- I guess the COMS which say what it contains")
                       [if (LITATOM NAME)
                           then (if (SETQ DEF (GETFILEDEF NAME))
                                        then (UPDATEFILES)
                                              (LIST (LISTP (GETTOPVAL (FILECOMS DEF)))
                                                    (fetch TOBEDUMPED
                                                       of (fetch FILEPROP of DEF))
                                                    (LISTP (fetch FILEDATES of DEF])
                (TEMPLATES (if (AND (LITATOM NAME)
                                        (SETQ DEF (GETTEMPLATE NAME)))
                               then (LIST 'SETTEMPLATE (KWOTE NAME)
                                              (KWOTE DEF))))
                (MACROS [if [AND (LITATOM NAME)
                                     (SETQ DEF (for X on (GETPROPLIST NAME)
                                                  by (CDDR X) when (FMEMB (CAR X)
                                                                                  MACROPROPS)
                                                  join (LIST (CAR X)
                                                                 (CADR X]
                            then `(PUTPROPS ,NAME ,@DEF])
                (EXPRESSIONS (LISTP NAME))
                (PROPS [AND (LISTP NAME)
                            (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME))
                                                 [FUNCTION (LAMBDA (X)
                                                             (EQ X (CADR NAME]
                                                 (FUNCTION CDDR)))
                                 (LIST 'PUTPROPS (CAR NAME)
                                       (CADR NAME)
                                       (CADR DEF])
                (FILEPKGCOMS [AND (LITATOM NAME)
                                  (PROG ((COM (FILEPKGCOM NAME))
                                         (TYP (FILEPKGTYPE NAME)))
                                        (RETURN (COND
                                                   ((AND COM TYP)
                                                    (LIST (CONS 'COM COM)
                                                          (CONS 'TYPE TYP)))
                                                   (COM (LIST (CONS 'COM COM)))
                                                   (TYP (LIST (CONS 'TYPE TYP])
                (FILEVARS (COND
                             ((AND (LITATOM NAME)
                                   (LISTP (SETQ DEF (GETTOPVAL NAME)))
                                   (WHEREIS NAME 'FILEVARS))
                              DEF)
                             (T 'NOBIND)))
                (LET
                 ((COMS (LIST (MAKENEWCOM NAME TYPE)))
                  FILE)
                 [COND
                    ((NOT (SETQ DEF (GETDEFCOM COMS)))
                     (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
                         (RESETLST
                             (RESETSAVE PRETTYFLG)
                             (RESETSAVE FONTCHANGEFLG)
                             [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
                             (PRETTYDEFCOMS COMS)
                             (SETFILEPTR FILE 0)
                             [SETQ DEF
                              (for X in (READFILE FILE)
                                 join
                                 (SELECTQ (CAR X)
                                     ((*) 
                                          NIL)
                                     (DECLARE%: (for Y on (CDR X)
                                                   unless (SELECTQ (CAR Y)
                                                                  ((COPYWHEN EVAL@LOADWHEN 
                                                                          EVAL@COMPILEWHEN) 
                                                                       (RETURN (LIST Y)))
                                                                  (FMEMB (CAR Y)
                                                                         DECLARETAGSLST))
                                                   collect (CAR Y)))
                                     (CL:EVAL-WHEN (CDDR X))
                                     (PROGN (CDR X))
                                     (LIST X]
                             (SETQ NOCOPY T)))]
                 (MKPROGN DEF]
           (fetch NULLDEF of TYPE))
          (GETDEFERR NAME TYPE OPTIONS))
         DEF])

(GETDEFERR
  [LAMBDA (NAME TYPE OPTIONS MSG)                        (* lmm "13-Jul-85 04:11")
    (DECLARE (USEDFREE NODEF))                           (* ; 
                                       "Message non-null if looking for saved or filed definition.")
    (PROG (TEM)
          (RETURN (COND
                     ((EQMEMB 'NOERROR OPTIONS)              (* ; 
                                               "We want to do the string search in the HASDEF case")
                      (RETURN (fetch NULLDEF of TYPE)))
                     [(AND (NULL MSG)
                           (EQMEMB 'SPELL OPTIONS)
                           (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS)
                                                                          'SPELL)
                                                                   T)))
                           (NEQ TEM NAME))
                      (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS]
                     (T (for O inside OPTIONS when (STRINGP O)
                           do (RETFROM 'GETDEF O)
                           finally (ERROR NAME (CONS TYPE '(definition not found))
                                              T])

(GETDEFFROMFILE
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: " 1-Oct-86 22:10")

    (* ;; "Tries to get definition from source file.  If successful, returns the definition.  Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.")

    (DECLARE (SPECVARS NAME))
    (bind (NOTFOUND _ "not found")
           DEF SOURCE TEM2 for FILE inside (COND
                                                      ((EQ SOURCE 'FILE)
                                                       (WHEREIS NAME TYPE T))
                                                      (T SOURCE))
       when
       (AND
        (SETQ SOURCE (FINDFILE FILE T))
        (NEQ
         [SETQ DEF
          (COND
             ((SETQ TEM2 (fetch FILEGETDEF of TYPE))
              (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND))
             (T
              (SELECTQ TYPE
                  (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  ((VARS FILEVARS) 
                       (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (COND
                     [(SETQ DEF (GET TYPE 'DEFINERS))
                      (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF
                                        `(LAMBDA (FIRST SECOND)
                                           (AND (MEMB FIRST ',DEF)
                                                (OR (EQ SECOND NAME)
                                                    (AND (MEMB SECOND '(%( %[))
                                                         (PROGN (RATOM)
                                                                (RATOM)
                                                                (RATOM)
                                                                (EQ NAME (RATOM]
                                                             (* ; "ick!  Should use real closure")
                           (if (EQ (CAAR VAL)
                                       'NOT-FOUND)
                               then NOTFOUND
                             elseif (CDR VAL)
                               then (CONS 'PROGN VAL)
                             else (CAR VAL]
                     (T (RESETLST
                            (RESETSAVE (RESETUNDO))
                            [LET (LOAD-VERBOSE-STREAM)
                                 (DECLARE (SPECVARS LOAD-VERBOSE-STREAM))
                                                             (* ; 
                                                     "just in case we get a PRETTYCOMPRINT in here")
                                 (LOADFNS NIL SOURCE 'PROP (COND
                                                              ((LITATOM NAME)
                                                             (* ; 
                                         "If an atom, only bother with expressions that contain it")
                                                               (CONS (LIST '& '|..| NAME)))
                                                              (T T]
                            (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))]
         NOTFOUND)) do (AND (EQ SOURCE 'FILE)
                                (OR (FMEMB FILE FILELST)
                                    (CL:FORMAT T "(from ~A)~%%" SOURCE))) 
                                                             (* ; 
                                                        "Copying and dwimifying are done in GETDEF")
                          (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
                                                                  (APPEND '(no definition on)
                                                                         (MKLIST SOURCE])

(GETDEFSAVED
  [LAMBDA (NAME TYPE OPTIONS)                          (* ; "Edited 11-Aug-87 18:14 by cutting")
                                                             (* ; 
                                                           "Gets the `saved' definition--source=T")
    (SELECTQ TYPE
        (FNS (OR (GETPROP NAME 'EXPR)
                 (GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
        (VARS                                                (* ; 
                               "The value of a variable is never substituted into and never COPIED")
              (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
                                                                                'VALUE)
                 do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS 
                                                                     "no saved value for "))))
        (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS)))
            (GETDEFERR NAME TYPE OPTIONS "no saved definition for "])

(PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* ; "Edited  8-Apr-87 12:52 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE)))
         (COND
            (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON))
            (T (SELECTQ TYPE
                   (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON))
                   (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON))
                   (EVAL DEFINITION))
               NAME])

(EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)
    (DECLARE (LOCALVARS . T)
           (SPECVARS SOURCE))                          (* ; "Edited 27-Jul-87 11:04 by cutting")

    (* ;; "lets you edit anything.  Given name and type, call editor on the definition (loading it in from SOURCE if necessary).  If you change it, then the definition gets unsaved.  OPTIONS is passed through from ED to the editor.")

    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (COND
       ((AND (fetch EDITDEF of TYPE)
             (APPLY* (fetch EDITDEF of TYPE)
                    NAME TYPE SOURCE EDITCOMS OPTIONS)))
       ((AND (EQ TYPE 'FNS)
             (NULL SOURCE))                                  (* ; 
                                "special hack for EDITDEF of FNS because of ability to EDITLOADFNS")
        (EDITDEF.FNS NAME EDITCOMS OPTIONS))
       (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))
    NAME])

(DEFAULT.EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 11-Jun-92 16:26 by cat")
    (PROG [(DEF (COND
                   [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
                   [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
                   [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
                   (T (LET ((FILES (WHEREIS NAME TYPE T)))
                           (CL:IF (NULL FILES)
                               (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE)
                               [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME 
                                                         FILES)
                                                  (CL:IF (CL:ENDP (CDR FILES))
                                                      (CL:IF (CL:Y-OR-N-P 
                                                                    "Shall I load this file PROP? ")
                                                             (CAR FILES))
                                                      (ASKUSER NIL NIL 
                                                             "indicate which file to load PROP: "
                                                             (MAKEKEYLST FILES)
                                                             T))]
                                    (CL:WHEN FILE
                                        (LOAD FILE 'PROP)
                                        (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])]

     (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")

          (DECLARE (SPECVARS RETRY))

     (* ;; "what is RETRY ???")

          (SETQ RETRY)
          (CL:WHEN DEF
              (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
                                                             (* ; 
                                             "this function is called when there were changes made")
                                                        (FIXEDITDATE DEF)
                                                             (* ; "fix the edit date first - jtm")
                                                        (PUTDEF NAME TYPE DEF)
                                                        (MARKASCHANGED NAME TYPE 'CHANGED)

                                 (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition.  doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here.  this sometimes results in MARKASCHANGED getting called twice.")

                                                        ]
                     OPTIONS))])

(EDITDEF.FILES
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 18-Mar-87 16:07 by woz")
    (EDITDEF (FILECOMS NAME)
           'VARS SOURCE EDITCOMS OPTIONS])

(LOADDEF
  [LAMBDA (NAME TYPE SOURCE)                             (* lmm "13-SEP-78 01:34")
    (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY])

(DWIMDEF
  [LAMBDA (DEF FN SOURCE)                                (* lmm " 6-Jun-86 17:23")
    (AND [OR (EQ DWIMIFYCOMPFLG T)
             (EQ CLISPIFYPRETTYFLG T)
             (EQ (CAR (CADDR DEF))
                 'CLISP%:)
             (SELECTQ SOURCE
                 ((CURRENT SAVED FILE ?) 
                      NIL)
                 (AND (LITATOM SOURCE)
                      (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE]
         (LET ((NOSPELLFLG T)
               (DWIMESSGAG T)
               FILEPKGFLG LISPXHIST)
              (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST))
              (DWIMIFY0 DEF (COND
                               ((OR (LISTP FN)
                                    (NULL FN))
                                '?)
                               (T FN))
                     NIL DEF])

(DELDEF
  [LAMBDA (NAME TYPE)                                    (* ; "Edited  5-Dec-86 06:20 by lmm")
    (PROG (TEM)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
      LP  [COND
             ((SETQ TEM (fetch DELDEF of TYPE))
              (APPLY* TEM NAME TYPE))
             (T (SELECTQ TYPE
                    (FNS                                     (* ; 
  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such")
                         (AND (EXPRP NAME)
                              (/PUTD NAME))
                         (REMPROP NAME 'EXPR)
                         [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME])
                    (VARS (/SETTOPVAL NAME 'NOBIND))
                    (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES)
                              do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST]
                           (/replace FILEPROP of NAME with NIL)
                           (/replace FILECHANGES of NAME with NIL)
                           (/replace FILEDATES of NAME with NIL)
                           (FLUSHFILEMAPS NAME))
                    (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME)
                                 (DELFROMLIST 'FILEPKGTYPES NAME)
                                 (for FIELD on (FILEPKGCOM NAME)
                                    by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD)
                                                                      NIL))
                                 (for FIELD on (FILEPKGTYPE NAME)
                                    by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD)
                                                                      NIL))
                                 (/replace ALLFIELDS of NAME with NIL))
                    (ALISTS [AND (LISTP NAME)
                                 (DELFROMLIST (CAR NAME)
                                        (FASSOC (CADR NAME)
                                               (GETTOPVAL (CAR NAME])
                    (MACROS (for P in MACROPROPS do (/REMPROP NAME P)))
                    (PROPS (AND (LISTP NAME)
                                (/REMPROP (CAR NAME)
                                       (CADR NAME))))
                    (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS))
                                 (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS
                                                                             ))
                                 (DELFROMLIST 'LISPXCOMS NAME)
                                 (DELFROMLIST 'HISTORYCOMS NAME))
                    (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet")
                           T]
          (MARKASCHANGED NAME TYPE 'DELETED)
          (RETURN NAME])

(DELFROMLIST
  [LAMBDA (VAR VAL)                                      (* rmk%: " 3-JAN-82 23:22")
    (AND (FMEMB VAL (GETTOPVAL VAR))
         (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR)
                                (FUNCTION (LAMBDA (X)
                                            (AND (NEQ X VAL)
                                                 (OR (NLISTP X)
                                                     (NEQ (CDR X)
                                                          VAL])

(HASDEF
  [LAMBDA (NAME TYPE SOURCE SPELLFLG)                    (* ; "Edited 31-Aug-87 18:02 by drc:")

    (* ;; "is NAME the name of something of type TYPE?  NIL SOURCE means 0, not ?")

    (DECLARE (SPECVARS TYPE))
    (COND
       [[OR (LISTP TYPE)
            (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG")
        (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
                                            (RETURN $$VAL]
       (T
        (PROG [(NODEF (fetch NULLDEF of TYPE))
               (OPTS '(NODWIM NOCOPY NOERROR HASDEF]
              (COND
                 ((NULL SOURCE)
                  (SETQQ SOURCE CURRENT)))
              (RETURN
               (SELECTQ SOURCE
                   ((CURRENT 0) 
                        [COND
                           ([OR
                             (MEMBER NAME (fetch CHANGED of TYPE))
                             (LET ((TM (fetch HASDEF of TYPE)))
                                  (COND
                                     (TM (APPLY* TM NAME TYPE SOURCE))
                                     [(NOT (LITATOM NAME))
                                      (SELECTQ TYPE
                                          (PROPS (AND (LISTP NAME)
                                                      (GETPROP (CAR NAME)
                                                             (CADR NAME))))
                                          ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS 
                                                  FIELDS USERMACROS FILEVARS FILEPKGCOMS) 
                                               NIL)
                                          (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                                     (T 
                                        (* ;; "symbol definitions")

                                        (SELECTQ TYPE
                                            (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS")
                                                                        "INTERLISP")))
                                                        (AND SYMBOL (BOUNDP SYMBOL))))
                                            (TEMPLATES (GETTEMPLATE NAME))
                                            (MACROS (GETLIS NAME MACROPROPS))
                                            (LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
                                                             (FASSOC NAME LISPXHISTORYMACROS)))
                                            (VARS (AND (NOT (CL:KEYWORDP NAME))
                                                       (NEQ (GETTOPVAL NAME)
                                                            'NOBIND)))
                                            (RECORDS (RECLOOK NAME))
                                            (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD]
                                                            (RETURN (AND TEM (EQ (CAR TEM)
                                                                                 'FORWORD)
                                                                         (GETPROP (CDR TEM)
                                                                                'I.S.OPR])
                                            (FNS (AND (OR (AND (GETD NAME)
                                                               (EXPRP (GETD NAME)))
                                                          (GET NAME 'EXPR))
                                                      (NOT (HASDEF NAME 'FUNCTIONS SOURCE))))
                                            (FIELDS (RECORDFIELD? NAME))
                                            (USERMACROS (FASSOC NAME USERMACROS))
                                            (FILEVARS)
                                            ((PROPS ALISTS DEFS EXPRESSIONS) 
                                                 NIL)
                                            (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
                                                             (FMEMB NAME FILEPKGTYPES)))
                                            (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                            (OR NAME T))
                           (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME)
                                         (FIXSPELL NAME NIL
                                                (SELECTQ TYPE
                                                    (FILES FILELST)
                                                    (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES))
                                                    (FIELDS (for X in USERRECLST
                                                               join (APPEND (RECORDFIELDNAMES
                                                                                 X))))
                                                    (RECORDS (for X in USERRECLST
                                                                when (LITATOM (CADR X))
                                                                collect (CADR X)))
                                                    (LISPXMACROS LISPXCOMS)
                                                    (I.S.OPRS I.S.OPRLST)
                                                    (USERMACROS (MAPCAR USERMACROS
                                                                       (FUNCTION CAR)))
                                                    USERWORDS)
                                                NIL
                                                (LISTP SPELLFLG)
                                                [FUNCTION (LAMBDA (X)
                                                            (HASDEF X TYPE 'CURRENT]
                                                NIL T))])
                   (? (OR (HASDEF NAME TYPE 'CURRENT)
                          (AND (LITATOM NAME)
                               (HASDEF NAME TYPE 'SAVED SPELLFLG))
                          (WHEREIS NAME TYPE T)))
                   ((SAVED T) 
                        (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS)))
                   (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])

(GETFILEDEF
  [LAMBDA (FILENAME)                                     (* lmm " 4-Jul-85 13:25")

    (* ;; 
  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST")

    (COND
       ((FMEMB FILENAME FILELST)
        FILENAME)
       (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T)
             do (COND
                       ((EQ (FILENAMEFIELD FILE 'NAME)
                            FILENAME)
                        (RETURN FILE])

(SAVEDEF
  [LAMBDA (NAME TYPE DEFINITION)                         (* JonL "24-Jul-84 20:11")
    (COND
       [(AND (LISTP NAME)
             (NULL TYPE))
        (MAPCAR NAME (FUNCTION (LAMBDA (I)
                                 (SAVEDEF I 'FNS]
       (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME)))
                        (/PUT NAME [SETQ TYPE (COND
                                                 ((SUBRP DEFINITION)
                                                  'SUBR)
                                                 ((EXPRP DEFINITION)
                                                  'EXPR)
                                                 ((CCODEP DEFINITION)
                                                  'CODE)
                                                 (T 'LIST]
                              DEFINITION)))
              (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME)))
                              'NOBIND)
                         (EQ DEFINITION (GETTOPVAL NAME))
                         (/PUT NAME (SETQ TYPE 'VALUE)
                               DEFINITION)))
              (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT
                                                          '(NOCOPY NOERROR NODWIM]
                   (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS))
                                                  (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME))
                                                                             SAVEDDEFS]
          TYPE])

(UNSAVEDEF
  [LAMBDA (NAME TYPE DEF)                                (* lmm " 6-Jun-86 17:24")
    (SELECTQ TYPE
        ((NIL EXPR CODE SUBR LIST) 
             (COND
                [(LISTP NAME)                                (* ; "for compatibility")
                 (MAPCAR NAME (FUNCTION (LAMBDA (X)
                                          (UNSAVED1 X TYPE]
                (T (UNSAVED1 NAME TYPE))))
        (PROG NIL
              [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
                                       'SAVED 0))
                  (RETURN (CONS TYPE '(not found]
              (COND
                 ((NEQ DFNFLG T)
                  (SAVEDEF NAME TYPE)
                  (LET ((DFNFLG T))
                       (PUTDEF NAME TYPE DEF)))
                 (T (PUTDEF NAME TYPE DEF)))
              (RETURN TYPE])

(COMPAREDEFS
  [LAMBDA (NAME TYPE SOURCES)                            (* lmm " 4-Jul-85 14:37")
    (COND
       ((AND (LISTP TYPE)
             (GETFILEPKGTYPE SOURCES NIL T))
        (swap TYPE SOURCES)))
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T]
          [COND
             ((NULL SOURCES)
              (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE))
                       (SOME SRCS (FUNCTION (LAMBDA (FILE)
                                              (MEMBER NAME (CDR (ASSOC TYPE
                                                                       (fetch TOBEDUMPED
                                                                          of (fetch FILEPROP
                                                                                    of FILE]
                   (push SRCS 'CURRENT]
          (SETQ SRCS (for SRC in SRCS
                        when (COND
                                    ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
                                          (fetch NULLDEF of TYPE))
                                     (OR [SOME DEFS (FUNCTION (LAMBDA (DP)
                                                                (COMPARELST DEF (CDR DP]
                                         (push DEFS (CONS SRC DEF)))
                                     T)
                                    (T (PRINTOUT T "No " SRC " definition found for " NAME T)
                                       NIL)) collect SRC))
          (RETURN (COND
                     ((NULL SRCS)
                      '(no definitions found))
                     ((NULL (CDR SRCS))
                      '(only one definition found))
                     ((CDR DEFS)
                      [for S1 on (DREVERSE DEFS)
                         do (for S2 on (CDR S1) do (PRIN2 NAME T T)
                                                                  (AND (CAAR S1)
                                                                       (PRIN1 " from " T)
                                                                       (PRIN2 (CAAR S1)
                                                                              T T))
                                                                  (PRIN1 " and " T)
                                                                  (PRIN2 NAME T T)
                                                                  (COND
                                                                     ((CAAR S2)
                                                                      (PRIN1 " from " T)
                                                                      (PRIN2 (CAAR S2)
                                                                             T T)))
                                                                  (PRIN1 " differ:" T)
                                                                  (TERPRI T)
                                                                  (COMPARELISTS (CDAR S1)
                                                                         (CDAR S2]
                      'DIFFERENT)
                     (T 'SAME])

(COMPARE
  [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2)             (* lmm " 5-SEP-78 13:37")
    (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY]
           (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY]
          (COND
             ((COMPARELST DEF1 DEF2)
              (RETURN)))
          (PRIN2 NAME1 T T)
          (COND
             (SOURCE1 (PRIN1 " from " T)
                    (PRIN2 SOURCE1 T T)))
          (PRIN1 " and " T)
          (PRIN2 NAME2 T T)
          (COND
             (SOURCE2 (PRIN1 " from " T)
                    (PRIN2 SOURCE2 T T)))
          (PRIN1 " differ:" T)
          (TERPRI T)
          (COMPARELISTS DEF1 DEF2)
          (RETURN T])

(TYPESOF
  [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER)
                                                          (* ; "Edited  2-Aug-88 02:08 by masinter")

    (* ;; "return list of all known types which NAME names")

    (LET
     (FOUND SHADOWED)
     (if (FMEMB SOURCE '(? NIL))
         then (CL:FLET [(RSHADOW NIL (for X in FOUND
                                            do (for Y in (CDR (FASSOC X SHADOW-TYPES))
                                                      do (if (FMEMB Y FOUND)
                                                                 then 
                                                             (* ; "shadower found before shadowed")
                                                                       (SETQ FOUND (REMOVE Y FOUND]
                         (LET (NOTFOUND NEWTYPES)
                              (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                                 when [AND (LITATOM TYPE)
                                               (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                               (OR (NULL FILTER)
                                                   (CL:FUNCALL FILTER TYPE))
                                               (NOT (find X in FOUND
                                                       suchthat (FMEMB TYPE
                                                                           (CDR (FASSOC X 
                                                                                       SHADOW-TYPES]
                                 do (if [OR (HASDEF NAME TYPE 'CURRENT)
                                                    (AND (LITATOM NAME)
                                                         (HASDEF NAME TYPE 'SAVED]
                                            then (push FOUND TYPE)
                                          else (push NOTFOUND TYPE)))
                              (RSHADOW)
                              [for FILE in FILELST while NOTFOUND
                                 when [NEQ T (fetch LOADTYPE of (GETPROP FILE
                                                                                   'FILE]
                                 do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND
                                                                      (FILECOMS FILE)
                                                                      'TYPESOF))
                                            then [bind X for TYPE in NEWTYPES
                                                        when (FMEMB TYPE NOTFOUND)
                                                        do (push FOUND TYPE)
                                                              (if (SETQ X (FASSOC TYPE 
                                                                                     SHADOW-TYPES))
                                                                  then (SETQ NOTFOUND
                                                                            (LDIFFERENCE NOTFOUND X))
                                                                else (SETQ NOTFOUND
                                                                          (REMOVE TYPE NOTFOUND]
                                                  (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES]
                              (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF))
                                  then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND))
                                        (SETQ FOUND (UNION NEWTYPES FOUND)))
                              (RSHADOW)
                              FOUND))
       else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                   when (AND (LITATOM TYPE)
                                 (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                 (OR (NULL FILTER)
                                     (CL:FUNCALL FILTER TYPE))
                                 (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE)))
     FOUND])
)

(RPAQ? WHEREIS.HASH )



(* ; "Must come after PUTDEF")

(DEFINEQ

(FIXEDITDATE
  [LAMBDA (EXPR)                                         (* ; "Edited 17-Jul-89 11:13 by jtm:")
                                                             (* NOBIND "18-JUL-78 21:11")
                                                             (* Inserts or replaces previous edit 
                                                           date)
    (AND INITIALS (LISTP EXPR)
         (LISTP (CDR EXPR))
         (PROG (E)
               (COND
                  ((FMEMB (CAR EXPR)
                          LAMBDASPLST)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR)))
                  [(FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-ARGLIST-DEFINERS)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR))
                   (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
                      finally (SETQ E (CDR E]
                  ((FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-NAME-DEFINERS)

                   (* ;; "insert the edit date after the name")

                   (SETQ E (CDDR EXPR)))
                  (T (RETURN)))
           RETRY
               [COND
                  ((NLISTP E)
                   (RETURN))
                  ((LISTP (CAR E))
                   (SELECTQ (CAAR E)
                       ((CLISP%: DECLARE) 
                            (SETQ E (CDR E))
                            (GO RETRY))
                       (BREAK1 (COND
                                  ((EQ (CAR (CADAR E))
                                       'PROGN)
                                   (SETQ E (CDR (CADAR E)))
                                   (GO RETRY))))
                       (ADV-PROG                             (* No easy way to mark cleanly the 
                                                           date of an advised function)
                                 (RETURN))
                       (COND
                          ((AND (EQ (CAAR E)
                                    COMMENTFLG)
                                (EQ (CADAR E)
                                    'DECLARATIONS%:))
                           (SETQ E (CDR E))
                           (GO RETRY]
               (COND
                  ([for TAIL on E while (AND (LISTP (CAR TAIL))
                                                         (EQ (CAAR TAIL)
                                                             COMMENTFLG))
                      do (COND
                                ((AND (LISTP (CDR TAIL))
                                      (EDITDATE? (CAR TAIL)))
                                 (/RPLACA TAIL (EDITDATE (CAR TAIL)
                                                      INITIALS))
                                 (RETURN T]                  (* scans the comments for a 
                                                           timestamp for this user.)
                   NIL)
                  (T                                         (* attach the new timestamp at the 
                                                           beginning of the comments.)
                     (/ATTACH (EDITDATE NIL INITIALS)
                            E)))
               (RETURN EXPR])

(EDITDATE?
  [LAMBDA (COMMENT)                                      (* ; "Edited 11-Jun-92 16:44 by cat")
                                                             (* ; "Edited 13-Jul-89 09:30 by jtm:")
                                                             (* lmm "21-Mar-85 08:45")

         (* Tests to see if a given common is in fact an edit date --
       this has to be general enough to recognize the most comment comment forms while 
       specific enough to not recognize things that are not edit dates)

    (DECLARE (LOCALVARS . T))                            (* jtm%: changed test so that it 
                                                           creates one timestamp per user.)
    (COND
       [(LISTP COMMENT)
        (COND
           ((EQ (CAR COMMENT)
                COMMENTFLG)
            [COND
               (NIL (NULL NORMALCOMMENTSFLG)
                    (SETQ COMMENT (GETCOMMENT COMMENT]
            (COND
               ([OR (NOT (LISTP (CDR COMMENT)))
                    (NOT (LISTP (CDDR COMMENT]
                NIL)
               [(EQ (CADR COMMENT)
                    ';)                                      (* ; "CL style comment")
                (STRPOS INITIALS (CADDR COMMENT)
                       (IMINUS (NCHARS INITIALS]
               (T                                            (* ; "IL style comment")
                  (EQ (CADR COMMENT)
                      INITIALS]
       ((STRINGP COMMENT])
)



(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")


(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))

(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
)



(* ;; 
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
)

(DEFINEQ

(FILEPKGCOM
  [LAMBDA N                                              (* JonL "10-Jul-84 19:38")
    (PROG (TEM (COM (ARG N 1)))
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in '(MACRO CONTENTS DELETE ADD)
                             when (SETQ TEM (FILEPKGCOM COM FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                               (LIST 'COM T))
                          (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                               (LIST 'COM TEM]
                     ((EQ N 2)
                      (SELECTQ (ARG N 2)
                          (ADD (fetch ADD of COM))
                          (DELETE (fetch DELETE of COM))
                          (MACRO (fetch MACRO of COM))
                          ((CONTENTS CONTAIN) 
                               [OR (fetch (FILEPKGCOM CONTENTS) of COM)
                                   (COND
                                      ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM))
                                       (COND
                                          ((EQ COM 'NILL)
                                           COM)
                                          [(EQ (CAR COM)
                                               'LAMBDA)
                                           (CONS (CAR COM)
                                                 (CONS [CONS (CAADR COM)
                                                             (CONS (OR (CADDR (CADR COM))
                                                                       'NAME)
                                                                   (CONS (CADR (CADR COM))
                                                                         (CDDDR (CADR COM]
                                                       (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM]
                                          (T (LIST 'LAMBDA '(COM TYPE NAME)
                                                   (CONS COM '(COM TYPE NAME])
                          (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                        T)
                                   (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST])
                          (ERROR (ARG N 2)
                                 "not file package command property")))
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'COM)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                (/SETTOPVAL 'FILEPKGCOMSPLST
                                                       (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST])
                                         (COND
                                            ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGCOMSPLST
                                                      (CONS (CONS COM TEM)
                                                            (GETTOPVAL 'FILEPKGCOMSPLST]
                                    (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                    (/SETTOPVAL 'FILEPKGCOMSPLST
                                                           (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                       (SELECTQ (ARG N I)
                                           (ADD (/replace (FILEPKGCOM ADD) of COM
                                                   with TEM))
                                           (DELETE (/replace (FILEPKGCOM DELETE) of
                                                                                         COM
                                                      with TEM))
                                           (MACRO (/replace (FILEPKGCOM MACRO) of COM
                                                     with TEM))
                                           ((CONTENTS CONTAIN) 
                                                (/replace (FILEPKGCOM CONTENTS) of COM
                                                   with TEM))
                                           (ERROR (ARG N I)
                                                  "not file package command property"]
                        (MARKASCHANGED COM 'FILEPKGCOMS])

(FILEPKGTYPE
  [LAMBDA N                                              (* lmm " 5-Jul-85 09:07")
    (PROG ((TYPE (ARG N 1))
           TEM)
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in (UNION '(DESCRIPTION)
                                                       FILEPKGTYPEPROPS)
                             when (SETQ TEM (FILEPKGTYPE TYPE FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                               (LIST 'TYPE T))
                          (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]
                               (LIST 'TYPE TEM]
                     [(EQ N 2)
                      (if (FMEMB (ARG N 2)
                                     FILEPKGTYPEPROPS)
                          then (GETPROP TYPE (ARG N 2))
                        else (SELECTQ (ARG N 2)
                                     (DESCRIPTION (fetch DESCRIPTION of TYPE))
                                     (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                                                    T)
                                               (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES])
                                     (ERROR (ARG N 2)
                                            "not file package type property"]
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'TYPE)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T (OR (FMEMB TYPE FILEPKGTYPES)
                                                (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES))))
                                         (COND
                                            ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES))
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM)
                                                                               FILEPKGTYPES]
                                    (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES)
                                                    (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES
                                                                                    ]
                                       (if (FMEMB (ARG N I)
                                                      FILEPKGTYPEPROPS)
                                           then (if TEM
                                                        then (/PUTPROP TYPE (ARG N I)
                                                                        TEM)
                                                      else (/REMPROP TYPE (ARG N I)))
                                         else (SELECTQ (ARG N I)
                                                      (DESCRIPTION (/replace DESCRIPTION
                                                                      of TYPE with TEM))
                                                      (ERROR (ARG N I)
                                                             "not file package command/type property"
                                                             ]
                        (MARKASCHANGED TYPE 'FILEPKGCOMS])
)

(PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS)))

(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)

(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE)
                                                                       (* Revert to NILL when no 
                                                                          longer coercing 
                                                                          PRETTYDEFMACROS to 
                                                                          FILEPKGCOMS)
                                                                       (AND (EQ TYPE 'FILEPKGCOMS)
                                                                            (INFILECOMTAIL COM]
                                                  (TYPE DESCRIPTION "file package commands/types" 
                                                        GETDEF T PUTDEF FILEPKGCOMS.PUTDEF)))
(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X]
                                             (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF 
                                                   WHENCHANGED (ALISTS.WHENCHANGED))))
(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X])
(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS)))
(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED (
                                                                              EXPRESSIONS.WHENCHANGED
                                                                                               )
                                                        EDITDEF NILL)))
(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL)))
(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)
                                                   (TYPE TYPE FILEPKGCOMS)))
(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X]
                                                 CONTENTS
                                                 (LAMBDA (COM NAME TYPE)
                                                        (AND (EQ TYPE 'FILES)
                                                             (SUBSET (INFILECOMTAIL COM)
                                                                    (FUNCTION LITATOM]
                                            (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED)
                                                  EDITDEF EDITDEF.FILES)))
(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X)))
                                               (TYPE NULLDEF NOBIND EDITDEF NILL)))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (FN)
                                                                         (AND (GETPROP FN
                                                                                     'FUNCTIONS)
                                                                              (CL:WARN 
                                                                      "~A has a FUNCTIONS definition"
                                                                                     FN]
                                                  (ORIGINAL (FNS . X)))
                                               CONTENTS NILL)
                                          (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF
                                                T)))
(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X)))
                                                       CONTENTS
                                                       (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                              (AND (NULL ONFILETYPE)
                                                                   (EQ TYPE 'RECORDS)
                                                                   (INFILECOMTAIL COM])
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS)))
(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X)))
                                                       CONTENTS NILL)
                                                  (TYPE DESCRIPTION "LISPX commands")))
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM
                                              MACRO
                                              [X
                                               (DECLARE%:
                                                EVAL@COMPILE
                                                (P
                                                 *
                                                 (MAPCAR
                                                  'X
                                                  (FUNCTION
                                                   (LAMBDA (Y)
                                                          (LET [[FNDEF (GETDEF Y 'FUNCTIONS
                                                                              'CURRENT
                                                                              '(NOCOPY NOERROR]
                                                                (MACDEF (GETDEF Y 'MACROS
                                                                               'CURRENT
                                                                               '(NOCOPY NOERROR]
                                                               (COND
                                                                ((AND FNDEF (EQ (CAR FNDEF)
                                                                                'DEFMACRO))
                                                                 (CL:WARN 
                           "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S."
                                                                        FNDEF)
                                                                 (LIST 'PROGN FNDEF MACDEF))
                                                                (T (OR MACDEF (CL:CERROR 
                                                          "Go ahead and finish writing out the file."
                                                                                     
                                                                       "No MACROS definition for ~A."
                                                                                     Y)
                                                                       (GETDEF Y 'MACROS 'CURRENT]
                                              CONTENTS NILL)
                                             (TYPE DESCRIPTION "Interlisp macros" GETDEF 
                                                   MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY))))
(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)))
(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X]
                                            (TYPE DESCRIPTION "property lists" WHENCHANGED (
                                                                                    PROPS.WHENCHANGED
                                                                                            ))))
(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM
                                               MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (RECORD)
                                                                         (AND (GETPROP RECORD
                                                                                     'STRUCTURES)
                                                                              (CL:WARN 
                                                                     "~A has a STRUCTURES definition"
                                                                                     RECORD]
                                                  (E (RECORDECLARATIONS . X))
                                                  (INITRECORDS . X))
                                               CONTENTS
                                               (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                      (AND (EQ TYPE 'FIELDS)
                                                           (NULL ONFILETYPE)
                                                           (MAPCONC (INFILECOMTAIL COM)
                                                                  (FUNCTION (LAMBDA
                                                                             (X)
                                                                             (APPEND (
                                                                                     RECORDFIELDNAMES
                                                                                      X]
                                              (TYPE DESCRIPTION "records" DELDEF
                                                    (LAMBDA (X)
                                                           (/SETTOPVAL 'USERRECLST
                                                                  (REMOVE (RECLOOK X)
                                                                         USERRECLST])
(PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X)))
                                                      CONTENTS
                                                      (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                             (AND (NULL ONFILETYPE)
                                                                  (EQ TYPE 'RECORDS)
                                                                  (INFILECOMTAIL COM])
(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X)))
                                                      CONTENTS NILL)
                                                 (TYPE DESCRIPTION "edit macros")))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                                (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                          (VAR)
                                                                          (AND (GETPROP VAR
                                                                                      'VARIABLES)
                                                                               (CL:WARN 
                                                                 "~A also has a VARIABLES definition"
                                                                                      VAR]
                                                   (ORIGINAL (VARS . X)))
                                                CONTENTS NILL)
                                           (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF 
                                                 VARS.PUTDEF)))
(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL)))
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X)
                                                                     (P (CONSTANTS . X])

(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
                           (VARIABLES VARS CONSTANTS))

(RPAQ? SAVEDDEFS )



(* ; "EDITCALLERS")

(DEFINEQ

(FINDCALLERS
  [LAMBDA (ATOMS FILES)                                  (* lmm "30-SEP-78 01:36")
    (PROG ((X (EDITCALLERS ATOMS FILES T)))
          (RETURN (NCONC (DREVERSE (CDR X))
                         (AND (CAR X)
                              (LIST (CONS (COND
                                             ((CDR X)
                                              '"plus other places on")
                                             (T 'on))
                                          (CAR X])

(EDITCALLERS
  [LAMBDA (ATOMS FILES COMS)                            (* ; "Edited  8-Aug-2020 17:32 by rmk:")
                                                             (* bvm%: " 3-Nov-86 17:30")
    (LET
     (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN)
     [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS]
     [for FILE in (COND
                             ((NULL FILES)
                              FILELST)
                             ((EQ FILES T)
                              (UNION SYSFILES FILELST))
                             ((LISTP FILES)
                              FILES)
                             (T (LIST FILES)))
        do
        (RESETLST
            [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I)
                  (OR (SETQ FULL (FINDFILE FILE))
                      (RETURN (LISPXPRINT (CONS FILE '(not found))
                                     T T)))
                  [RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                       (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT]
                  (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM)))
                  (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP)
                         (OR (GET-ENVIRONMENT-AND-FILEMAP FULL)
                             (\PARSE-FILE-HEADER FILESTREAM)))

             (* ;; "Get reader environment of file.  The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists.  Otherwise, read the top of the file")

                  (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV)))
                  (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL))
                  [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS)))
                      (push FFILEPOSPATTERNS
                             (CONS RDTBL (SETQ PATTERNS
                                          (for ATOM in ATOMS
                                             collect (CONCAT
                                                          (COND
                                                             ((EQ (CHCON1 ATOM)
                                                                  (CHARCODE ESCAPE))
                                                              (SETQ ATOM (SUBSTRING ATOM 2 -1))
                                                              "")
                                                             (T " "))
                                                          [COND
                                                             ((SETQ I (STRPOS ' ATOM))
                                                              (SUBSTRING ATOM 1 (SUB1 I)))
                                                             ((STRINGP ATOM))
                                                             (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE
                                                                                  ATOM)))
                                                             (* ; 
                                                           "Keep MKSTRING from putting a prefix on")
                                                                     (MKSTRING ATOM T RDTBL]
                                                          (COND
                                                             (I "")
                                                             (T " "]
                  (for PATTERN in PATTERNS
                     do
                     (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0)))
                     (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA))
                        do
                        (COND
                           ((NULL PRINTFLG)                  (* ; 
                                   "cause the printing of the filename to be saved on history list")
                            (SETQ PRINTFLG T)
                            (LISPXPRIN2 FULL T T T)

                            (* ;; "print with NODOFLG=T means just to record the printing;  the idea is that only those files in which something is found will be remembered on the history list")

                            (LISPXPRIN1 ": " T NIL T)))
                        [OR
                         [AND (NEQ MAP T)
                              (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0)
                                                                    (SETQ MAP (OR (GETFILEMAP 
                                                                                         FILESTREAM)
                                                                                  (LOADFILEMAP 
                                                                                         FILESTREAM]
                                                         (PROGN 
                                                             (* ; "file has no filemap")
                                                                (SETQ MAP (SETQ NOMAPFLG T))
                                                                (LISPXPRIN1 " no filemap!" T)
                                                                NIL)))
                                 thereis (AND (ILESSP (CAR X)
                                                         I)
                                                  (IGREATERP (CADR X)
                                                         I)
                                                  (for Z in (CDDR X)
                                                     thereis (COND
                                                                    ((AND (ILESSP (CADR Z)
                                                                                 I)
                                                                          (IGREATERP (CDDR Z)
                                                                                 I))
                                                                     [COND
                                                                        ((NOT (FMEMB (CAR Z)
                                                                                     FNS))
                                                                         (SETQ FNS
                                                                          (CONS (LISPXPRIN2
                                                                                 (CAR Z)
                                                                                 T T)
                                                                                FNS]
                                                                     (SETQ I (CDDR Z))
                                                                     T]
                         (PROGN (LISPXPRIN2 I T T)
                                (OR (FMEMB FILE OTHERSFILES)
                                    (SETQ OTHERSFILES (CONS FILE OTHERSFILES]
                        (LISPXSPACES 1 T)))
                  (COND
                     (PRINTFLG (LISPXTERPRI T))
                     (T (TERPRI T)))
                  (COND
                     ((NEQ COMS T)
                      (COND
                         ((OR FNS OTHERSFILES)
                          (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS))
                                 FULL EDITPATTERN COMS (NULL OTHERSFILES))
                          (SETQ OTHERSFILES)
                          (SETQ FNS])]
     (COND
        ((EQ COMS T)
         (CONS OTHERSFILES FNS])

(EDITFROMFILE
  [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES)     (* rmk%: "14-Mar-85 21:51")
    (RESETVARS [(EDITLOADFNSFLG (COND
                                   ((EQ EDITLOADFNSFLG T)
                                    '(T . NO))
                                   (T EDITLOADFNSFLG]
               (PROG NIL
                     [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN]
                     (AND
                      (SETQ FILES (for FILE inside (OR FILES FILELST)
                                     when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE)
                                                                             FILELST))
                                                  (COND
                                                     ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" 
                                                                                        FILE)
                                                                    NIL T))
                                                      (LOADFROM FILE FNS 'ALLPROP)
                                                      T))) collect FILE))
                      (for TYPE in [COND
                                              ((LISTP ONLYTYPES))
                                              (ONLYTYPES '(FNS))
                                              (T 

                                 (* ;; "Move FNS to the front.  This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.")

                                                 (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES]
                         when (AND (LITATOM TYPE)
                                       (NEQ (fetch EDITDEF of TYPE)
                                            'NILL))
                         do
                         (PROG (SEEN)
                               (for FILE inside FILES
                                  do
                                  (for NAME in [COND
                                                          ((AND (EQ TYPE 'FNS)
                                                                (NEQ FNS T))
                                                             (* ; 
                                                    "for this type, we are given the list of items")
                                                           (PROG1 FNS (SETQ FNS NIL)))
                                                          (T (* ; 
                             "only want the values of `TYPE' which are not part of some other type")
                                                             (FILECOMSLST FILE TYPE 'EDIT]
                                     unless (MEMBER NAME SEEN)
                                     do
                                     (ERSETQ
                                      (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT
                                                             '(NOCOPY NOERROR))
                                                      (GETDEF NAME TYPE 'SAVED
                                                             '(NOCOPY NOERROR]

                                 (* ;; "If definition has been loaded, it may have been editted.  Work on that explicitly instead of bringing in a file definition to smash the users previous changes.  Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS.  --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file.  But ...  rmk")

                                            (COND
                                               ((OR (AND (EQ TYPE 'FNS)
                                                         (NEQ FNS T))
                                                    (AND (LISTP DEF)
                                                         (LOOKIN DEF EDITPATTERN)))
                                                (COND
                                                   ((NULL SEEN)
                                                    (LISPXPRIN1 "editing the " T)
                                                    (LISPXPRIN1 (OR (fetch DESCRIPTION
                                                                       of TYPE)
                                                                    TYPE)
                                                           T)
                                                    (LISPXSPACES 1 T)))
                                                (SETQ SEEN (CONS NAME SEEN))
                                                (LISPXPRIN2 NAME T T)
                                                (LISPXPRIN1 ":
" T)
                                                (COND
                                                   ((NOT
                                                     (ERSETQ (EDITDEF
                                                              NAME TYPE
                                                              (OR (AND DEF (CONS '= DEF))
                                                                  FILE)
                                                              EDITCOMS)))
                                                    (LISPXPRIN1 "failed" T)))
                                                (LISPXTERPRI T])

(FINDATS
  [LAMBDA (X L)                                          (* lmm "11-FEB-78 16:03")
    (COND
       ((NLISTP X)
        (FMEMB X L))
       (T (OR (FINDATS (CAR X)
                     L)
              (FINDATS (CDR X)
                     L])

(LOOKIN
  [LAMBDA (X PAT)                                        (* lmm "11-MAR-78 14:20")
    (COND
       ([AND (EQ (CAR PAT)
                 '*ANY*)
             (EVERY (CDR PAT)
                    (FUNCTION (LAMBDA (X)
                                (AND (LITATOM X)
                                     (NOT (STRPOS ' X]
        (FINDATS X (CDR PAT)))
       (T (EDITFINDP X PAT T])
)
(DEFINEQ

(SEPRCASE
  [LAMBDA (CLFLG RDTBL)                                  (* bvm%: "24-Oct-86 18:16")

    (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent.  Based on FILERDTBL, but others are close with respect to breaks and seprs")

    (OR RDTBL (SETQ RDTBL FILERDTBL))
    (OR [ARRAYP (CDR (ASSOC RDTBL (COND
                                     (CLFLG CLISPCASEARRAYS)
                                     (T SEPRCASEARRAYS]
        (LET ((CA (CASEARRAY)))
             [if (READTABLEPROP RDTBL 'CASEINSENSITIVE)
                 then                                    (* ; "map upper into lower case")
                       (for I from (CHARCODE A) to (CHARCODE Z)
                          do (SETCASEARRAY CA I (+ I (- (CHARCODE a)
                                                            (CHARCODE A]
             (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS
                                                    collect (CHCON1 Y)))
                                      (GETSEPR RDTBL)
                                      (GETBRK RDTBL)) do (SETCASEARRAY CA X 0))
             (if *PACKAGE*
                 then                                    (* ; 
                               "symbols qualified with package prefix will otherwise be unfindable")
                       (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR)
                              0))
             (SETQ CA (CONS RDTBL CA))
             (COND
                (CLFLG (push CLISPCASEARRAYS CA))
                (T (push SEPRCASEARRAYS CA)))
             (CDR CA])
)

(RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL))

(RPAQ? SEPRCASEARRAYS )

(RPAQ? CLISPCASEARRAYS )

(MOVD? 'INFILEP 'FINDFILE)

                                                             (* ; "or else from SPELLFILE")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
       (NOLINKFNS LOADFROM))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)
)



(* ; "EXPORT")

(DEFINEQ

(IMPORTFILE
  [LAMBDA (FILE RETURNFLG)                               (* lmm " 6-Jun-86 17:43")
    (RESETLST
        [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT]
        (RESETSAVE (INPUT FILE))                             (* ; 
                "Reset INPUT in case some form on the file's action is to read the next expression")
        (NCONC [COND
                  ((EQ RETURNFLG T)                          (* ; 
                                           "Just creating EXPORTS.ALL, don't side-effect the world")
                   (IMPORTFILESCAN FILE RETURNFLG))
                  (T (LET (FILEPKGFLG DFNFLG)
                          (IMPORTFILESCAN FILE RETURNFLG]
               (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE))
                                     ''IMPORTDATE
                                     (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE]
                      RETURNFLG)))])

(IMPORTEVAL
  [LAMBDA (FORM RETURNFLG)                               (* ; "Edited  2-May-87 18:57 by Pavel")

    (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")

    (AND (LISTP FORM)
         (SELECTQ (CAR FORM)
             (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (/DECLAREDATATYPE                               (* ; 
                    "Ignore datatype initializations -- we only need the record declaration itself")
                  NIL)
             (PROGN                                          (* ; "default: eval and/or return it")
                    (AND (NEQ RETURNFLG T)
                         (EVAL FORM))
                    (AND RETURNFLG (LIST FORM])

(IMPORTFILESCAN
  [LAMBDA (FILE RETURNFLG)                               (* bvm%: "24-Oct-86 19:31")
    (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
        (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
           join (until (EQUAL (SETQ DEF (READ FILE))
                                      ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])

(CHECKIMPORTS
  [LAMBDA (FILES NOASKFLG)                               (* rmk%: "19-FEB-83 16:31")
                                                             (* ; 
                                           "Loads exported definitions from new versions of FILES.")
    (COND
       ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE
                            when [AND (SETQ FULLFILENAME (FINDFILE FILE T))
                                          (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE)
                                                                     'IMPORTDATE]
                                              (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 
                                                                     'ICREATIONDATE]
                            collect (LIST FILE FULLFILENAME)))
             (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from "
                                                       (MAPCAR FILES (FUNCTION CAR)))
                                          '((Y "es
")
                                            (N "o
"))
                                          T)
                              (N NIL)
                              T)))
        (for FILE in FILES do (IMPORTFILE (CADR FILE])

(GATHEREXPORTS
  [LAMBDA (FROMFILES TOFILE FLG)                         (* bvm%: "14-Oct-86 23:12")
                                                             (* ; 
                                        "Copies all exported definitions from FROMFILES to TOFILE.")
    (RESETLST
        [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE)
                             (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT]
        (RESETSAVE (OUTPUT TOFILE))
        (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*))
             (SETQ ENV (if ENV
                           then (\DO-DEFINE-FILE-INFO NIL ENV)
                         else *OLD-INTERLISP-READ-ENVIRONMENT*))
             (WITH-READER-ENVIRONMENT ENV
                 (PRINT-READER-ENVIRONMENT ENV)
                 (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T)
                        " ON "
                        (DATE)
                        "%"  T)" T "(LISPXTERPRI T)" T)
                 (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T))
                                                              (FUNCTION PRINT))
                                                       (TERPRI))
                 (PRINT 'STOP)
                 (TERPRI)
                 (FULLNAME TOFILE))))])

(\DUMPEXPORTS
  [NLAMBDA COMS                                          (* bvm%: "24-Oct-86 19:42")

(* ;;; "Dumps an EXPORT form.  IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.")

    (PRIN1 "(")
    (PRIN2 '*)
    (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2))               (* ; 
                                   "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE")
    (for TAIL on COMS do (PRETTYCOM (CAR TAIL)))
    (TERPRI)
    (PRINT ENDEXPORTDEFFORM)
    (TERPRI])
)
(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X])

(RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")

(RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)
)



(* ; "for GAINSPACE")

(DEFINEQ

(CLEARFILEPKG
  [LAMBDA (FLG)                                          (* bvm%: "29-Aug-86 13:02")
    (PROG NIL
          (COND
             ((SELECTQ FLG
                  ((E T) 
                       T)
                  (Y (TERPRI T)
                     (PRIN1 "you can delete just the filemaps -
" T)
                     (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? "
                                   '((Y "es - everything" RETURN T)
                                     (N "o - just the filemaps" RETURN NIL)
                                     (E "verything" RETURN T)
                                     (F "ilemaps only" RETURN NIL]
                            (TERPRI T)))
                  NIL)
              (UPDATEFILES)
              [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE)
                                                        (COND
                                                           ((fetch TOBEDUMPED
                                                               of (fetch FILEPROP
                                                                         of FILE))
                                                            (PRINT FILE T T)
                                                            (PRIN1 " has changes, not wiped." T)
                                                            (TERPRI T)
                                                            T)
                                                           (T (replace FILEPROP of FILE
                                                                 with NIL)
                                                              (replace FILECHANGES of FILE
                                                                 with NIL)
                                                              (SMASHFILECOMS FILE)
                                                              (NCONC1 SYSFILES FILE)
                                                              NIL]
              (SETQ LOADEDFILELST)))
          (SELECTQ FLG
              ((NIL T))
              (CLRHASH *FILEMAP-HASH*])
)

(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                    ((Y "es")
                                     (N "o")
                                     (E . "verything")
                                     (F "ilemaps only
"))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SMASHPROPSLST1)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST 
       DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS 
       LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG 
       MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS 
       FILEPKGTYPEPROPS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
       (SPECVARS COMSNAME))

(BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
       (NOLINKFNS . T)
       (SPECVARS COMSNAME)
       (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))

(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS 
       INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
       (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
       INFILECOMSPROP)

(BLOCK%: NIL MAKEFILE (LOCALVARS . T)
       (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))

(BLOCK%: ADDFILE ADDFILE ADDFILE0)

(BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))

(BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
       COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF 
       EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE
       FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES 
       MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED 
       MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
       SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF 
       UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS 
                          EDITLOADFNSFLG LOADOPTIONS)
       (LOCALVARS . T))

(BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))

(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
       GETDEFSAVED (RETFNS GETDEFCOM)
       (NOLINKFNS . T)
       (GLOBALVARS NOT-FOUNDTAG))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS 
                          MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS 
                          PRETTYDEFMACROS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1995 2018 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (22824 24529 (SEARCHPRETTYTYPELST 22834 . 23813) (PRETTYDEFMACROS 23815 . 24273) (
FILEPKGCOMPROPS 24275 . 24527)) (25331 59272 (CLEANUP 25341 . 26729) (COMPILEFILES 26731 . 27007) (
COMPILEFILES0 27009 . 27729) (CONTINUEDIT 27731 . 29151) (MAKEFILE 29153 . 40795) (FILECHANGES 40797
 . 43132) (FILEPKG.MERGECHANGES 43134 . 43957) (FILEPKG.CHANGEDFNS 43959 . 44271) (MAKEFILE1 44273 . 
48543) (COMPILE-FILE? 48545 . 49877) (MAKEFILES 49879 . 51572) (ADDFILE 51574 . 54095) (ADDFILE0 54097
 . 58233) (LISTFILES 58235 . 59270)) (59960 95200 (FILEPKGCHANGES 59970 . 61320) (GETFILEPKGTYPE 61322
 . 64395) (MARKASCHANGED 64397 . 66034) (FILECOMS 66036 . 66420) (WHEREIS 66422 . 67842) (
SMASHFILECOMS 67844 . 68079) (FILEFNSLST 68081 . 68243) (FILECOMSLST 68245 . 68729) (UPDATEFILES 68731
 . 74031) (INFILECOMS? 74033 . 75936) (INFILECOMTAIL 75938 . 77078) (INFILECOMS 77080 . 77241) (
INFILECOM 77243 . 87452) (INFILECOMSVALS 87454 . 87781) (INFILECOMSVAL 87783 . 88785) (INFILECOMSPROP 
88787 . 89616) (IFCPROPS 89618 . 90879) (IFCEXPRTYPE 90881 . 91392) (IFCPROPSCAN 91394 . 92447) (
IFCDECLARE 92449 . 93760) (INFILEPAIRS 93762 . 94094) (INFILECOMSMACRO 94096 . 95198)) (95235 126011 (
FILES? 95245 . 97438) (FILES?1 97440 . 98090) (FILES?PRINTLST 98092 . 98874) (ADDTOFILES? 98876 . 
109478) (ADDTOFILE 109480 . 110396) (WHATIS 110398 . 112374) (ADDTOCOMS 112376 . 114020) (ADDTOCOM 
114022 . 120569) (ADDTOCOM1 120571 . 121742) (ADDNEWCOM 121744 . 122794) (MAKENEWCOM 122796 . 124639) 
(DEFAULTMAKENEWCOM 124641 . 126009)) (126081 128898 (MERGEINSERT 126091 . 128434) (MERGEINSERT1 128436
 . 128896)) (130397 141309 (DELFROMFILES 130407 . 131257) (DELFROMCOMS 131259 . 132938) (DELFROMCOM 
132940 . 138808) (DELFROMCOM1 138810 . 139607) (REMOVEITEM 139609 . 140483) (MOVETOFILE 140485 . 
141307)) (141523 143892 (SAVEPUT 141533 . 143890)) (144017 152341 (UNMARKASCHANGED 144027 . 145735) (
PREEDITFN 145737 . 148248) (POSTEDITPROPS 148250 . 150751) (POSTEDITALISTS 150753 . 152339)) (152490 
173044 (ALISTS.GETDEF 152500 . 152879) (ALISTS.WHENCHANGED 152881 . 153525) (CLEARCLISPARRAY 153527 . 
154701) (EXPRESSIONS.WHENCHANGED 154703 . 155077) (MAKEALISTCOMS 155079 . 156152) (MAKEFILESCOMS 
156154 . 157591) (MAKELISPXMACROSCOMS 157593 . 159611) (MAKEPROPSCOMS 159613 . 160311) (
MAKEUSERMACROSCOMS 160313 . 162113) (PROPS.WHENCHANGED 162115 . 162736) (FILEGETDEF.LISPXMACROS 162738
 . 164180) (FILEGETDEF.ALISTS 164182 . 164801) (FILEGETDEF.RECORDS 164803 . 165734) (FILEGETDEF.PROPS 
165736 . 166528) (FILEGETDEF.MACROS 166530 . 167590) (FILEGETDEF.VARS 167592 . 168008) (FILEGETDEF.FNS
 168010 . 169374) (FILEPKGCOMS.PUTDEF 169376 . 171816) (FILES.PUTDEF 171818 . 172775) (VARS.PUTDEF 
172777 . 172920) (FILES.WHENCHANGED 172922 . 173042)) (175066 182499 (RENAME 175076 . 176477) (
CHANGECALLERS 176479 . 182497)) (182500 230448 (SHOWDEF 182510 . 183303) (COPYDEF 183305 . 185779) (
GETDEF 185781 . 188057) (GETDEFCOM 188059 . 189025) (GETDEFCOM0 189027 . 190373) (GETDEFCURRENT 190375
 . 196795) (GETDEFERR 196797 . 198098) (GETDEFFROMFILE 198100 . 202380) (GETDEFSAVED 202382 . 203486) 
(PUTDEF 203488 . 204191) (EDITDEF 204193 . 205170) (DEFAULT.EDITDEF 205172 . 208008) (EDITDEF.FILES 
208010 . 208211) (LOADDEF 208213 . 208389) (DWIMDEF 208391 . 209245) (DELDEF 209247 . 212261) (
DELFROMLIST 212263 . 212767) (HASDEF 212769 . 219091) (GETFILEDEF 219093 . 219615) (SAVEDEF 219617 . 
221276) (UNSAVEDEF 221278 . 222174) (COMPAREDEFS 222176 . 225478) (COMPARE 225480 . 226184) (TYPESOF 
226186 . 230446)) (230515 235558 (FIXEDITDATE 230525 . 234028) (EDITDATE? 234030 . 235556)) (235977 
244563 (FILEPKGCOM 235987 . 240920) (FILEPKGTYPE 240922 . 244561)) (256600 271152 (FINDCALLERS 256610
 . 257125) (EDITCALLERS 257127 . 264785) (EDITFROMFILE 264787 . 270467) (FINDATS 270469 . 270741) (
LOOKIN 270743 . 271150)) (271153 272880 (SEPRCASE 271163 . 272878)) (273397 278939 (IMPORTFILE 273407
 . 274381) (IMPORTEVAL 274383 . 275263) (IMPORTFILESCAN 275265 . 275686) (CHECKIMPORTS 275688 . 277024
) (GATHEREXPORTS 277026 . 278349) (\DUMPEXPORTS 278351 . 278937)) (279277 281485 (CLEARFILEPKG 279287
 . 281483)))))
STOP
\ No newline at end of file
diff --git a/sources/FILEPKG.~11~ b/sources/FILEPKG.~11~
deleted file mode 100644
index 452adc78..00000000
--- a/sources/FILEPKG.~11~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "10-Aug-2020 21:24:58" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;11 284888 

      changes to%:  (VARS FILEPKGCOMS)
                    (FNS ADDTOFILES?)

      previous date%: " 8-Aug-2020 17:33:31" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;9)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020 by Venue & Xerox Corporation.  All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")

(PRETTYCOMPRINT FILEPKGCOMS)

(RPAQQ FILEPKGCOMS
       [(COMS                                                (* ; 
            "standard records for accessing file  package type/command parts.  Exported for PRETTY")
              (VARS FILEPKGTYPEPROPS)
              (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
              (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
              (INITRECORDS * FILEPKGRECORDS))
        [DECLARE%: EVAL@COMPILE DOCOPY 

               (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.")

               (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES 
                                       PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS
                                       PRETTYFLG))
                  (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES 
                                       NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS]
        (INITVARS (MSDATABASELST))
        [COMS 
              (* ;; "making, adding, listing, compiling files")

              (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES 
                   FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE
                   ADDFILE0 LISTFILES)
              (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
                     (FILELST)
                     (LOADEDFILELST)
                     (NOTLISTEDFILES)
                     (NOTCOMPILEDFILES)
                     (MAKEFILEFORMS)
                     (NILCOMS))
              (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% 
                              F ST STF (REC . RC)
                              (BREC . RC)
                              (TC . C)
                              (BC . C)
                              (TCOMPL . C)
                              (BCOMPL . C)))
              (INITVARS (MAKEFILEREMAKEFLG T)
                     (CLEANUPOPTIONS '(RC]
        (COMS 
              (* ;; "scanning file coms")

              (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS 
                   FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM
                   INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                   IFCDECLARE INFILEPAIRS INFILECOMSMACRO))
        (COMS 
              (* ;; "adding to a file")

              (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM 
                   ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM)
              (INITVARS (DEFAULTCOMHASFILEFLG))
              (ADDVARS (MARKASCHANGEDFNS))
              (FNS MERGEINSERT MERGEINSERT1)
              
              (* ;; "RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file")

              (VARS [ADDTOFILEKEYLST `(("[" "" EXPLAINSTRING 
                                           "[ -- prettyprint the item to terminal and then ask again"
                                            NOECHOFLG T)
                                       (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG
                                          T)
                                       (,(CHARACTER (CHARCODE LF))
                                        "" EXPLAINSTRING "{line-feed} - same as previous response" 
                                        NOECHOFLG T)
                                       (" " ,(CONCATCODES (LIST (CHARCODE SPACE)
                                                                (CHARCODE EOL)))
                                            EXPLAINSTRING "{space} - no action" NOECHOFLG T)
                                       ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
                                            EXPLAINSTRING
                                            ,(CONCAT "] - nowhere, item is marked as a dummy"
                                                    (CHARACTER (CHARCODE EOL)))
                                            NOECHOFLG T)
                                       ["(" "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
                                            (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE))
                                                                 ,(CHARACTER (CHARCODE EOL]
                                                RETURN
                                                (CDR ANSWER]
                                       (@ "Near: " EXPLAINSTRING 
                                          "@ other-item   -- put the item near the other item" 
                                          NOECHOFLG T KEYLST (( "" CONFIRMFLG
                                                                 [,(CHARACTER (CHARCODE EOL]
                                                                 RETURN ANSWER)))
                                       [,(CHARACTER (CHARCODE CR))
                                        "" RETURN ,(CHARACTER (CHARCODE SPACE]
                                       ("" "File name: " EXPLAINSTRING "a file name" KEYLST (]
                    (LASTFILE)))
        (COMS 
              (* ;; "deleting an item from a file")

              (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE)
              (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
                 (MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
              (ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
        [COMS                                                (* ; 
                      "functions for doing things and marking them changed and auxiliary functions")
              (FNS SAVEPUT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
                                                     (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
              (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
              (ADDVARS (LISPXFNS (PUT . SAVEPUT)
                              (PUTPROP . SAVEPUT]
        (COMS                                                (* ; 
                                                  "sub-functions for file package commands & types")
              (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED 
                   MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS 
                   PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS 
                   FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS 
                   FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED)
              (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO)
                     (SYSPROPS PROPTYPE))
              (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT 
                    FILETYPE)
              (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS 
                    LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS 
                    PRETTYPRINTYPEMACROS USERMACROS))
        (COMS                                                (* ; 
                    "Define the commands below AFTER the various properties have been established.")
              (USERMACROS M))
        (COMS                                                (* ; "GETDEF methods")
              (FNS RENAME CHANGECALLERS)
              (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
                   GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF 
                   DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
              (INITVARS (WHEREIS.HASH)))
                                                             (* ; "Must come after PUTDEF")
        (FNS FIXEDITDATE EDITDATE?)
                                                             (* ; 
                                  "Edit date support for all kinds of definers (from PARC 6/10/92)")
        [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
              (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
        (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
        (COMS 
              (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")

              (FNS FILEPKGCOM FILEPKGTYPE)
              (PROP ARGNAMES FILEPKGCOM)
              (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
                     (FILEPKGTYPES FILEPKGCOMS))
              (FILEPKGCOMS FILEPKGCOMS)
              (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS
                     INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS
                     OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS))
        (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS)
                        (VARIABLES VARS CONSTANTS)))
        (INITVARS (SAVEDDEFS))
        (COMS                                                (* ; "EDITCALLERS")
              (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
              (FNS SEPRCASE)
              [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL]
              (INITVARS (SEPRCASEARRAYS)
                     (CLISPCASEARRAYS))
              (P (MOVD? 'INFILEP 'FINDFILE)
                                                             (* ; "or else from SPELLFILE"))
              (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
                             (NOLINKFNS LOADFROM)))
              (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS))
        (COMS                                                (* ; "EXPORT")
              (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS)
              (FILEPKGCOMS EXPORT)
              [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
                     (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"]
              (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM))
        (COMS                                                (* ; "for GAINSPACE")
              (FNS CLEARFILEPKG)
              [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                              ((Y "es")
                                               (N "o")
                                               (E . "verything")
                                               (F "ilemaps only
"]
              (GLOBALVARS SMASHPROPSLST1))
        (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT 
               DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 
               I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS 
               MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS 
               SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS)
        (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
                       (SPECVARS COMSNAME))
               (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
                      (NOLINKFNS . T)
                      (SPECVARS COMSNAME)
                      (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
               (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL 
                      INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                      IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
                      INFILECOMSPROP)
               (NIL MAKEFILE (LOCALVARS . T)
                    (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
               (ADDFILE ADDFILE ADDFILE0)
               (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
               (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
                    COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES 
                    EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM 
                    FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL 
                    LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS 
                    MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE 
                    POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
                    SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED 
                    UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS 
                                                 COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
                    (LOCALVARS . T))
               (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
               (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
                      GETDEFSAVED (RETFNS GETDEFCOM)
                      (NOLINKFNS . T)
                      (GLOBALVARS NOT-FOUNDTAG)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS 
                               MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP 
                               FILEPKGCOMPROPS PRETTYDEFMACROS)
                      (NLAML)
                      (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES])



(* ; "standard records for accessing file  package type/command parts.  Exported for PRETTY")


(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF CANFILEDEF FILEGETDEF))
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(DECLARE%: EVAL@COMPILE

(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
                                               (T (/REMPROP DATUM 'PRETTYTYPE]
                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
                                  (STANDARD [COND
                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
                                                                (OR (LISTP (GETTOPVAL 
                                                                                  'PRETTYDEFMACROS))
                                                                    (SETTOPVAL 'PRETTYDEFMACROS
                                                                           (LIST (LIST DATUM]
                                               (T (SETTOPVAL 'PRETTYDEFMACROS
                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
                                                                                'PRETTYDEFMACROS))
                                                                (GETTOPVAL 'PRETTYDEFMACROS]
                                         UNDOABLE
                                         (COND
                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
                                                                        (LIST (LIST DATUM]
                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
                                                                                   'PRETTYDEFMACROS))
                                                             (GETTOPVAL 'PRETTYDEFMACROS]
                                                             (* Not an atom record cause want 
                                                           REMPROP on NILs.)
                                                             (* NOTE%: PRETTCOM on PRETTY has 
                                                           open-coded access to the MACRO 
                                                           property.)
                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
                                       FILEPKGCONTENTS)))

(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
                                                           )
                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
                                                                              DATUM)))
                                                           (STANDARD (SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                      DATUM NEWVALUE)
                                                                                     )
                                                                            NEWVALUE)
                                                                  UNDOABLE
                                                                  (/SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                    DATUM NEWVALUE))
                                                                         NEWVALUE)))
                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
                                                                             DATUM)))
                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
                                                                               DATUM NEWVALUE))
                                                                       NEWVALUE)))
                                                    (ALLFIELDS NIL (/SETTOPVAL
                                                                    'PRETTYTYPELST
                                                                    (REMOVE (SEARCHPRETTYTYPELST
                                                                             DATUM)
                                                                           (GETTOPVAL 'PRETTYTYPELST]
                                                             (* NOTE%: PRETTYCOM on PRETTY has 
                                                           open-coded access to GETDEF property)
                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                                                                   (PUT X
                                                                                        'PROPTYPE
                                                                                        'FILEPKGCOMS]
                                         (ADDTOVAR PRETTYTYPELST ))))

(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
                                                    UNDOABLE
                                                    (/PUTPROP DATUM 'FILE NEWVALUE])

(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))

(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
)

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
)

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(SEARCHPRETTYTYPELST
  [LAMBDA (TYPE FLG)                                     (* rmk%: " 3-JAN-82 22:55")
                                                             (* ; 
                                                           "access functions used by the records")
    (AND (LITATOM TYPE)
         (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X)
                                                               TYPE))
             (COND
                (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE
                                                                             'LST)
                                                                      TYPE NIL))
                                                      (GETTOPVAL 'PRETTYTYPELST]
                     (OR (LISTP (GETTOPVAL (CAR FLG)))
                         (/SETTOPVAL (CAR FLG)
                                NIL))
                     FLG])

(PRETTYDEFMACROS
  [NLAMBDA ARGS                                          (* lmm " 5-SEP-78 16:16")
                                                             (* ; 
                                                 "included so that old files will continue to load")
    (for X in ARGS collect (FILEPKGCOM (CAR X)
                                              'MACRO
                                              (CDR X])

(FILEPKGCOMPROPS
  [NLAMBDA PROPS
    (MAPC PROPS (FUNCTION (LAMBDA (Y)
                            (OR (MEMB Y SYSPROPS)
                                (SETQ SYSPROPS (CONS Y SYSPROPS)))
                            (PUT Y 'PROPTYPE 'FILEPKGCOMS])
)

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS 
                     *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG))

(CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS 
                     CLEANUPOPTIONS))
)

(RPAQ? MSDATABASELST )



(* ;; "making, adding, listing, compiling files")

(DEFINEQ

(CLEANUP
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (PROG (TEM1 TEM2 OPTIONS)
          (COND
             ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
              (SETQ OPTIONS (CAR FILES))
              (SETQ FILES (CDR FILES)))
             (T (SETQ OPTIONS CLEANUPOPTIONS)))
          (RETURN (APPEND (MAKEFILES OPTIONS FILES)
                         (COND
                            ((NOT (MEMB 'LIST OPTIONS))
                             NIL)
                            ((NULL FILES)
                             (LISTFILES))
                            ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES))
                                                             (* ; 
            "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.")
                             (APPLY 'LISTFILES TEM1)))
                         (COND
                            [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS]
                            ((NULL FILES)
                             (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES)
                                    (CDR TEM1))
                             TEM2)
                            ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES))
                             (COMPILEFILES0 TEM2 (CDR TEM1))
                             TEM2])

(COMPILEFILES
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (COND
       ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
        (COMPILEFILES0 (CDR FILES)
               (CAR FILES)))
       (T (COMPILEFILES0 FILES])

(COMPILEFILES0
  [LAMBDA (FILES OPTIONS)                                (* rmk%: "19-FEB-83 21:59")
    (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES)
       first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS))
                                (C (SETQ RCFLG NIL)
                                   (CDR OPTIONS))
                                (RC (CDR OPTIONS))
                                OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X)
                                                                           70 FILELST NIL X)
                                                                    (CAR X))
                                                        RCFLG OPTS X])

(CONTINUEDIT
  [LAMBDA (FILE)                                         (* bvm%: "30-Aug-86 15:09")
    (PROG (STREAM FL TEM FC ENV)
          (RESETLST
              [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT]
              (SETQ FILE (FULLNAME STREAM))
              (SETFILEPTR STREAM 0)
              (CL:MULTIPLE-VALUE-SETQ (ENV FC)
                     (\PARSE-FILE-HEADER STREAM 'RETURN)))
          (COND
             ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE]
              (LOADFROM FILE)                                (* ; 
                                                           "also calls addfile to notice the file.")
              ))
          (/replace FILECHANGES of FL with (FILECHANGES FC))
          [/replace FILEDATES of FL with
                                            (LIST (create FILEDATEPAIR
                                                         FILEDATE _ (CADR FC)
                                                         DATEFILENAME _ FILE)
                                                  (create FILEDATEPAIR
                                                         FILEDATE _
                                                         [CAR (SETQ TEM (CDR (MEMB 'date%: FC]
                                                         DATEFILENAME _ (CADR TEM]
          (RETURN FILE])

(MAKEFILE
  [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)           (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL;  LIST means list the FILE;  RC means RECOMPILE, C means COMPILEL;  --- for C AND RC assume ST unless next option is F.")

    (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS]
                           PRETTYFLG))
           (*PRINT-BASE* (if (EQ *PRINT-BASE* 8)
                             then 8
                           else                          (* ; "make sure radix is either 8 or 10, because all others don't read in like they print.  Maybe obsolete now with makefile environments")
                                 10))
           FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
          (DECLARE (CL:SPECIAL PRETTYFLG))
          (SETQ FILE (CAR Z))                                (* ; 
                                               "Necessary because FILE might have been misspelled.")
          (SETQ ROOTNAME (CADR Z))                           (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.")
          (SETQ FILEPROP (CDDR Z))
          (UPDATEFILES)                                  (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.")
          (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
          (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
          (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE))
      LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
                       (NULL FILEDATES))
              then                                       (* ; 
                   "File has never been loaded and never dumped i.e. user just set up COMS in core")
            elseif [OR (EQMEMB 'NEW OPTIONS)
                           (AND (NULL MAKEFILEREMAKEFLG)
                                (NOT (MEMB 'REMAKE OPTIONS]
              then (COND
                          ((AND (fetch LOADTYPE of FILEPROP)
                                (NEQ T (fetch LOADTYPE of FILEPROP)))
                           (LISPXPRIN2 FILE T T)
                           (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
                                           (LOADCOMP 
                                                  "the file was loaded for compilation purposes only")
                                           ((compiled Compiled COMPILED) 
                                                " -- only the compiled file has been loaded
")
                                           ((loadfns LOADFNS) 
                                                " -- only some of its symbolics have been loaded
")
                                           (SHOULDNT))
                                  T)
                           (COND
                              ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ")
                                    'Y)                      (* ; 
            "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.")
                               (GO OUT)))
                           (/replace LOADTYPE of FILEPROP with NIL)))
                    (SETQ SOURCEFILE NIL)
                    (SETQ REPRINTFNS NIL)
            elseif SOURCEFILE
              then                                       (* ; "source file given")
            elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T))
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
                                          (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE
                                                                              (fetch DATEFILENAME
                                                                                 of (CAR 
                                                                                            FILEDATES
                                                                                             ]
                                               (INFILEP SOURCEFILE)
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
              then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
                    (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
            elseif [AND (CDR FILEDATES)
                            [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
                            (EQUAL (FILEDATE SOURCEFILE)
                                   (fetch FILEDATE of (CADR FILEDATES]
              then 

                    (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.")

                    (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
                                         (fetch FILECHANGES of ROOTNAME)))
                    (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
            else (LISPXPRIN1 
                            '"can't find either the previous version or the original version of 
" T)
                  (LISPXPRIN2 FILE T T)
                  (LISPXPRIN1 '", so it will have to be written anew
" T)
                  (SETQ SOURCEFILE NIL)
                  (SETQ REPRINTFNS NIL)
                  (push OPTIONS 'NEW)
                  (SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
                  (GO LP0))
          (COND
             ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
                                          (LOADCOMP          (* ; 
                                                   "only loaded via LOADCOMP.  Need to do LOADFROM")
                                                    (LIST 'N SOURCEFILE "was loaded with LOADCOMP"
                                                          '- "LOADFROM it to obtain VARS/COMS"))
                                          (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%:
                                                                (fetch COMSNAME of FILEPROP))
                                                         (LIST 'Y "only compiled version of" ROOTNAME
                                                               
                                        "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions"
                                                               )))
                                          ((compiled loadfns) 
                                               (LIST 'N "Only some functions from" SOURCEFILE 
                                             "loaded via LOADFNS. Load all other expressions from it"
                                                     ))
                                          NIL)))
              (SELECTQ [ASKUSER DWIMWAIT (CAR Z)
                              (CDR Z)
                              '((Y "es
")
                                (N "o
")
                                (A "bort MAKEFILE
"]
                  (Y (SELECTQ (fetch LOADTYPE of FILEPROP)
                         (LOADCOMP                           (* ; 
                               "file was never actually loaded, just loadcomped.  thus no filecoms")
                                   (LOADFROM SOURCEFILE))
                         (Compiled 

                                 (* ;; "This is going to be a remake.  If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.")

                                   (LOADVARS 'DONTCOPY SOURCEFILE)
                                   (/replace LOADTYPE of FILEPROP with 'COMPILED)
                                                             (* ; "So wont have to be done again.")

                                 (* ;; "These are the only DECLARE:'s that are not also on the compiled file.  Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE:  Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)")

                                   )
                         ((loadfns compiled) 

                                 (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.")

                              (LOADVARS T SOURCEFILE))
                         NIL))
                  (A (GO OUT))
                  NIL)))
          (RESETLST
              [COND
                 ((MEMB 'NOCLISP OPTIONS)
                  (RESETSAVE PRETTYTRANFLG T))
                 ((MEMB 'CLISP%  OPTIONS)
                  (RESETSAVE PRETTYTRANFLG 'BOTH]
              (RESETSAVE %#UNDOSAVES)
              [COND
                 ((OR (MEMB 'CLISPIFY OPTIONS)
                      (MEMB 'CLISP OPTIONS))
                  (RESETSAVE CLISPIFYPRETTYFLG T))
                 ((OR (EQ FILETYPE 'CLISP)
                      (MEMB 'CLISP (LISTP FILETYPE)))
                  (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES]
              (for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
              (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
                                REPRINTFNS SOURCEFILE CHANGES)))
          (SETQ LASTFILE ROOTNAME)
          (/replace TOBEDUMPED of FILEPROP with NIL)
          (COND
             ((NOT (EQMEMB 'DON'TLIST FILETYPE))
              (pushnew NOTLISTEDFILES ROOTNAME)))
          (COND
             ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE))
              (pushnew NOTCOMPILEDFILES ROOTNAME)))
          [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL))
                                                 (SELECTQ OPT
                                                     (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                              (MAKEFILE1 FILE T (CDR TAIL))))
                                                     (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                             (MAKEFILE1 FILE NIL (CDR TAIL))))
                                                     (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
                                                                (APPLY 'LISTFILES (LIST FILE))))
                                                     (COND
                                                        ((MEMB OPT MAKEFILEOPTIONS))
                                                        ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL 
                                                                OPTIONS)
                                                         (GO $$LP))
                                                        (T (ERROR "Unrecognized MAKEFILE option" OPT]
          (RETURN FILE)
      OUT (RETURN (LIST FILE "-- MAKEFILE not performed."])

(FILECHANGES
  [LAMBDA (FILE TYPE)                                    (* bvm%: "30-Aug-86 15:08")

    (* ;; "If FILE is a list, it is assumed to be a file-created expressions;  otherwise, the filecreated expression is read from FILE.  If TYPE, returns the list of changed items of that type from the changes expression.  If TYPE=NIL, returns the whole list of typed change-lists")

    (PROG ([FCEXPR (OR (LISTP FILE)
                       (AND FILE (RESETLST
                                     (LET (OLDPTR STREAM)
                                          [if (SETQ STREAM (OPENP FILE 'INPUT))
                                              then (SETQ OLDPTR (GETFILEPTR STREAM))
                                                    (SETFILEPTR STREAM 0)
                                            else (RESETSAVE NIL (LIST 'CLOSEF
                                                                          (SETQ STREAM
                                                                           (OPENSTREAM FILE
                                                                                  'INPUT]
                                          (CL:MULTIPLE-VALUE-BIND (ENV FC)
                                                 (\PARSE-FILE-HEADER STREAM 'RETURN)
                                                 (if OLDPTR
                                                     then (SETFILEPTR STREAM OLDPTR))
                                                 FC)))]
           FNS CHANGES)
          (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR)))
                               (MEMB 'previous CHANGES)))
          [if (AND TYPE (NEQ TYPE 'FNS))
              then (RETURN (CDR (ASSOC TYPE CHANGES]
          (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM)))     (* ; 
                         "Old style changes expression listed FNS by name and other things by type")
          (RETURN (if TYPE
                      then                               (* ; "TYPE=FNS cause of test above.")
                            (NCONC FNS (CDR (ASSOC 'FNS CHANGES)))
                    elseif FNS
                      then (CONS (CONS 'FNS FNS)
                                     (SUBSET CHANGES (FUNCTION LISTP)))
                    else CHANGES])

(FILEPKG.MERGECHANGES
  [LAMBDA (C1 C2)                                        (* rmk%: "24-MAY-82 23:09")

    (* ;; "Merges 2 changes lists into a single one.  Treat LITATOM's as FNS, to accomodate old-style format on files.")

    (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND
                                                                                         E1)))
       in C2 do [COND
                           ((SETQ TEMP (ASSOC (CAR E2)
                                              VAL))
                            (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP))
                                           collect X)))
                           (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL])

(FILEPKG.CHANGEDFNS
  [LAMBDA (CHANGES)                                      (* rmk%: "20-MAY-82 22:00")

    (* ;; "Returns list of function names from a file-changes list.  Interprets old format (functions are atoms) and new format (with explicit type headers)")

    (CDR (ASSOC 'FNS CHANGES])

(MAKEFILE1
  [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES)            (* ; "Edited 29-Aug-89 11:46 by bvm")
    (PROG* ((ROOTNAME (ROOTFILENAME FILE))
            (COMPILER (COMPILE-FILE? ROOTNAME))
            GROUP)
           (COND
              ((AND (OR (EQ COMPILER 'BCOMPL)
                        (EQ COMPILER 'TCOMPL))
                    (NOT (FILEFNSLST ROOTNAME)))         (* ; 
                 "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.")
               (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
               (RETURN NIL)))
           (COND
              ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP))
                  suchthat (AND (NEQ X ROOTNAME)
                                    (OR (fetch TOBEDUMPED of (fetch FILEPROP of
                                                                                         X))
                                        (MEMB X OTHERFILES]

               (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled.  Wait.")

               (RETURN)))
           (LISPXPRIN1 '"
compiling " T)
           (LISPXPRINT (OR GROUP FILE)
                  T T)
           (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS)
                                                'ST)
                                            (EQ (CAR OPTIONS)
                                                'STF]
                             (FORGET-EXPRS? (EQ (CAR OPTIONS)
                                                'STF]
                            (SELECTQ COMPILER
                                ((FAKE-COMPILE-FILE)         (* ; 
                                               "The old CommonLispy interface to the ByteCompiler.")
                                     (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS
                                            (AND REDEFINE? (NOT FORGET-EXPRS?))))
                                ((CL:COMPILE-FILE)           (* ; "The new, improved (?) compiler")
                                     (CL:COMPILE-FILE FILE :LOAD (COND
                                                                    ((AND REDEFINE? (NOT 
                                                                                        FORGET-EXPRS?
                                                                                         ))
                                                                     :SAVE)
                                                                    (REDEFINE? T)
                                                                    (T NIL))))
                                ((TCOMPL BCOMPL)             (* ; "The old ByteCompiler")
                                     [IF (MEMB (CAR OPTIONS)
                                                   '(ST F S STF))
                                         THEN (LISPXUNREAD (LIST (CAR OPTIONS]
                                     [IF GROUP
                                         THEN 

                                               (* ;; 
                                   "File contained in FILEGROUP.  Therefore must be blockcompiled.")

                                               (IF RECOMPFLG
                                                   THEN (BRECOMPILE GROUP)
                                                 ELSE (BCOMPL GROUP))
                                       ELSEIF (EQ COMPILER 'TCOMPL)
                                         THEN (IF RECOMPFLG
                                                      THEN (RECOMPILE FILE)
                                                    ELSE (TCOMPL (LIST FILE)))
                                       ELSE (IF RECOMPFLG
                                                    THEN (BRECOMPILE FILE)
                                                  ELSE (BCOMPL (LIST FILE])
                                (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?...")))
                  T T])

(COMPILE-FILE?
  [LAMBDA (ROOTNAME)                                     (* ; "Edited 19-Jan-87 21:12 by Pavel")

(* ;;; "Which compiler should CLEANUP use?")

    (LET ((TYPE (GET ROOTNAME 'FILETYPE))
          (UNKNOWN NIL))
         (FOR X INSIDE TYPE DO (SELECTQ X
                                               ((TCOMPL :TCOMPL) 
                                                    (RETURN 'TCOMPL))
                                               ((BCOMPL :BCOMPL) 
                                                    (RETURN 'BCOMPL))
                                               ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) 
                                                    (RETURN 'FAKE-COMPILE-FILE))
                                               ((:COMPILE-FILE :XCL-COMPILE-FILE) 
                                                    (RETURN 'CL:COMPILE-FILE))
                                               ((CLISP) 
                                                    NIL)
                                               (SETQ UNKNOWN T))
            FINALLY (IF UNKNOWN
                            THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE
                                            ))
                  (RETURN *DEFAULT-CLEANUP-COMPILER*])

(MAKEFILES
  [LAMBDA (OPTIONS FILES)                                (* rmk%: "23-FEB-83 21:20")
    (RESETVARS (%#UNDOSAVES)                                 (* ; 
                                                   "Willing to save arbitrary amounts of undo info")
               (UPDATEFILES)
               [COND
                  ((NULL FILES)
                   (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE
                                                                         (COND
                                                                            ((NULL FLG)
                                                             (* ; "Gets printed the first time")
                                                                             
                                                                             '
                                        "****NOTE: the following are not contained on any file:
    ")
                                                                            (T '"    "]
                      do (SETQ FLG T) finally (AND FLG (ADDTOFILES?]
               (SETQ OPTIONS (MKLIST OPTIONS))
               (RETURN (for FILE inside (OR FILES FILELST)
                          when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP
                                                                          of (ROOTFILENAME FILE]
                          collect (LISPXPRIN2 FILE T T)
                                (LISPXPRIN1 '|...| T)
                                (PROG1 (MAKEFILE FILE OPTIONS)
                                       (LISPXTERPRI T])

(ADDFILE
  [LAMBDA (FILE LOADTYPE PRLST FCLST)                    (* bvm%: "29-Aug-86 12:22")

    (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           FLST VAL)
          [COND
             ((NOT FCLST)
              (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE)))
             [(NULL (CDR FCLST))                             (* ; "A simple symbolic file")
              (SETQ FCLST (CAR FCLST))
              (SETQ VAL (ADDFILE0 (COND
                                         ((LITATOM (CADR FCLST))
                                          (ROOTFILENAME (CADR FCLST)))
                                         (T ROOTNAME))
                               LOADTYPE FILE (CAR FCLST]
             (T 
                (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.")

                (SELECTQ LOADTYPE
                    ((T LOADFNS) 
                         (SETQ LOADTYPE 'Compiled))
                    (loadfns (SETQ LOADTYPE 'compiled))
                    (LOADCOMP                                (* ; 
                   "loadcomp on compiled file.  Don't notice since we don't know what its state is")
                              NIL)
                    (SHOULDNT))
                (for X in (CDR FCLST) when (LITATOM (CADR X))
                   do (push FLST (CADR X))
                         (OR (EQ LOADTYPE 'LOADCOMP)
                             (ADDFILE0 (ROOTFILENAME (CADR X))
                                    LOADTYPE
                                    (CADR X)
                                    (CAR X]
          (UPDATEFILES PRLST (OR FLST (LIST FILE)))
          [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES
                           when (AND (LITATOM TYPE)
                                         (SETQ CHANGED (fetch CHANGED of TYPE)))
                           do (/replace CHANGED of TYPE
                                     with (INTERSECTION (CDR (ASSOC TYPE PRLST))
                                                     CHANGED]
          (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS))
          (RETURN VAL])

(ADDFILE0
  [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT)               (* lmm "28-Nov-84 16:47")
    (PROG (COMS X FILEPROP FLG TEM)
      TOP (SETQ COMS (FILECOMS ROOTNAME))
          [COND
             ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME))
              (COND
                 ([AND LOADTYPE (FMEMB LOADTYPE
                                       (CDR (FMEMB (fetch LOADTYPE of FILEPROP)
                                                   '(LOADCOMP loadfns compiled Compiled LOADFNS 
                                                           COMPILED NIL T]
                  (/replace LOADTYPE of FILEPROP with LOADTYPE)

                  (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property.  'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file.  'Compiled' means all but DECLARE: expressions are in.  e.g. user does LOAD of a compiled file.  COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.  LOADFNS means everything in, e.g. user des LOADFROM symbolic file.  COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted.  NIL is a makefile when coms were set up in core.  T is full load of symbolic file.  The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.")

                  (* ;; "LOADCOMP means file was loadcomp'ed.  note that the actual structure is a tree, not a list, and the above is only an approximation.  if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc.  however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.")

                  (GO OUT))
                 (T (GO OUT1]
          (COND
             [(OR LOADTYPE (LISTP (GETTOPVAL COMS)))
              (SETQ FILEPROP (/replace FILEPROP of ROOTNAME
                                with (create FILEPROP
                                                COMSNAME _ COMS
                                                LOADTYPE _ LOADTYPE]
             (FLG (GO ERROR))
             ((AND DWIMFLG (EQ ROOTNAME FULLNAME)
                   (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T)))

              (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.")

              (SETQ FULLNAME ROOTNAME)
              (SETQ FLG T)                                   (* ; 
                                         "so wont try to spelling correct again if file isnt there")
              (GO TOP))
             (T (GO ERROR)))
      OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME
                               with (LIST (create FILEDATEPAIR
                                                     FILEDATE _ DAT
                                                     DATEFILENAME _ FULLNAME]
          (AND (EQ LOADTYPE T)
               (/replace TOBEDUMPED of FILEPROP with NIL))
      OUT1
          [COND
             ([AND (LISTP (GETTOPVAL COMS))
                   (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ; 
                                                          "coms wuld not be set up on a loadccomp.")
              (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST]
          (RETURN (COND
                     ((NULL LOADTYPE)                        (* ; "call from makefile.")
                      (CONS FULLNAME (CONS ROOTNAME FILEPROP)))
                     (T FILEPROP)))
      ERROR
          (ERROR FULLNAME "not file name." T])

(LISTFILES
  [NLAMBDA FILES                                         (* rmk%: " 3-Dec-84 08:58")
    (DECLARE (GLOBALVARS NOTLISTEDFILES))                (* ; "LISTFILES1 is machinedependent")
    (for FILE FULLNAME OPTIONS in (COND
                                             (FILES (SETQ FILES (NLAMBDA.ARGS FILES)))
                                             (T NOTLISTEDFILES))
       when (COND
                   ((LISTP FILE)
                    (SETQ OPTIONS (APPEND FILE OPTIONS))
                    NIL)
                   ((SETQ FULLNAME (FINDFILE FILE))
                    FULLNAME)
                   (T (printout T FILE " not found." T)
                      NIL)) collect [COND
                                           ((LISTFILES1 FULLNAME OPTIONS)
                                            (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
                                                                        NOTLISTEDFILES]
                                  FULLNAME])
)

(RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)

(RPAQ? FILELST )

(RPAQ? LOADEDFILELST )

(RPAQ? NOTLISTEDFILES )

(RPAQ? NOTCOMPILEDFILES )

(RPAQ? MAKEFILEFORMS )

(RPAQ? NILCOMS )

(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP%  F ST STF
                                 (REC . RC)
                                 (BREC . RC)
                                 (TC . C)
                                 (BC . C)
                                 (TCOMPL . C)
                                 (BCOMPL . C))

(RPAQ? MAKEFILEREMAKEFLG T)

(RPAQ? CLEANUPOPTIONS '(RC))



(* ;; "scanning file coms")

(DEFINEQ

(FILEPKGCHANGES
  [LAMBDA N                                              (* Pavel " 7-Oct-86 19:22")
    (COND
       [(EQ N 0)
        (PROG (TEM)
              (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X)
                                                                   (SETQ TEM (FILEPKGCHANGES
                                                                              X)))
                         collect (CONS X TEM]
       [(EQ (ARG N 1)
            T)
        (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES
                                                                                 X]
       [(EQ N 1)
        (COND
           [(LISTP (ARG N 1))
            (for X in (ARG N 1) when (FMEMB (CAR X)
                                                        FILEPKGTYPES)
               do (/replace CHANGED of (CAR X) with (CDR X]
           (T (for Y on (fetch CHANGED of (ARG N 1))
                 when [AND (CAR Y)
                               (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y)
                                                                                 Z]
                 collect (CAR Y]
       (T (/replace CHANGED of (ARG N 1) with (ARG N 2])

(GETFILEPKGTYPE
  [LAMBDA (TYPE ONLY NOERROR NAME)                       (* lmm "20-Nov-86 23:10")

    (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ")

    (COND
       [(LISTP TYPE)

        (* ;; " given a list of types, coerce them all or return NIL")

        (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME)
                                               (RETURN]
       ((EQ TYPE '?)

        (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ")

        (AND NAME (TYPESOF NAME)))
       [(AND (NEQ ONLY 'COMS)
             (OR (SELECTQ TYPE
                     (NIL 'FNS)
                     (T 'VARS)
                     NIL)
                 (for X in FILEPKGTYPES do (if (EQ TYPE X)
                                                           then 

                                                                 (* ;; "type matched exactly")

                                                                 (RETURN TYPE)
                                                         elseif (AND (LISTP X)
                                                                         (EQ TYPE (CAR X)))
                                                           then (RETURN (CDR X]
       [(AND (NEQ ONLY 'TYPE)
             (LITATOM TYPE)
             (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST))       (* ; "Prefer an exact match quickly")
                    ]
       [(AND (NEQ ONLY 'COMS)
             (LITATOM TYPE)
             (for X in FILEPKGTYPES bind NAME
                do (SETQ NAME (if (NLISTP X)
                                      then X
                                    else (CAR X))) 

                      (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization")

                      (AND (<= 0 (- (NCHARS NAME)
                                    (NCHARS TYPE))
                               1)
                           (STRPOS TYPE NAME)
                           (RETURN (if (EQ X NAME)
                                       then X
                                     else (CDR X]
       [(FIXSPELL TYPE NIL (SELECTQ ONLY
                               (TYPE FILEPKGTYPES)
                               (COMS FILEPKGCOMSPLST)
                               (UNION FILEPKGTYPES FILEPKGCOMSPLST]
       ((NOT NOERROR)
        (ERROR (SELECTQ ONLY
                   (TYPE "unrecognized manager definition type")
                   (COMS "unrecognized manager command")
                   "unrecognized manager definition-type/command")
               TYPE])

(MARKASCHANGED
  [LAMBDA (NAME TYPE REASON)                             (* ; "Edited 25-May-88 15:37 by drc:")
    (COND
       (FILEPKGFLG (SETQ REASON (SELECTQ REASON
                                    ((CLISP LOAD CHANGED DEFINED DELETED) 
                                         REASON)
                                    (NIL 'CHANGED)
                                    (T 'DEFINED)
                                    (ERROR "bad REASON in MARKASCHANGED" REASON)))
              (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (for FN inside (fetch WHENCHANGED of TYPE)
                 do (APPLY* FN NAME TYPE REASON))
              (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON))
              [COND
                 ((EQ REASON 'DELETED)
                  (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L)
                                                                                    NAME)
                     do (/RPLACA L NIL))                 (* ; 
                                                          "unmark as changed and remove from files")
                  (DELFROMFILES NAME TYPE))
                 (T (LET ((LST (push (fetch CHANGED of TYPE)
                                      NAME)))
                         (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST)
                                               LISPXHIST))   (* ; 
                             "UNDO by smashing with NIL;  makes calls to MARKASCHANGED independent")
                         ]
              NAME])

(FILECOMS
  [LAMBDA (FILE X)                                       (* rmk%: "19-FEB-83 13:55")
    (COND
       ((AND (NULL FILE)
             (NULL X))
        'NILCOMS)
       [(AND (OR (NULL X)
                 (EQ X 'COMS))
             (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE]
       (T (PACK* (NAMEFIELD FILE)
                 (OR X 'COMS])

(WHEREIS
  [LAMBDA (NAME TYPE FILES FN)                        (* ; "Edited 12-Jul-88 17:14 by MASINTER")

    (* ;; "T as a NAME has a special meaning to INFILECOMS?  so don't pass through.")

    (CL:UNLESS (EQ NAME T)
        (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES)
                                           FILELST)
                                      (FUNCTION (LAMBDA (FILE)
                                                  (INFILECOMS? NAME TYPE (FILECOMS FILE]
                               (AND (EQ FILES T)
                                    (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS)
                                    (LET ((FILES NIL))
                                         (for TY inside TYPE
                                            do (for FILE-NAME
                                                      in (XCL::HASH-FILE-WHERE-IS NAME
                                                                    (GETFILEPKGTYPE TYPE))
                                                      do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME))
                                                                    FILES)))
                                         (REVERSE FILES]
             (CL:IF FN
                 [MAPC IN-FILES (FUNCTION (LAMBDA (FILE)
                                            (APPLY* FN NAME FILE]
                 IN-FILES)))])

(SMASHFILECOMS
  [LAMBDA (FILE)                                         (* rmk%: "19-FEB-83 22:15")
    (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X)
       do (SETTOPVAL X 'NOBIND))
    FILE])

(FILEFNSLST
  [LAMBDA (FILE)                                         (* ; "Edited 14-Jun-90 19:30 by jds")
    (FILECOMSLST FILE '(FUNCTIONS FNS])

(FILECOMSLST
  [LAMBDA (FILE TYPE FLG)                                (* JonL "24-Jul-84 19:48")
                                                             (* ; 
                                                    "TYPE is coerced in the innards of INFILECOMS?")
    (COND
       ((EQ FLG 'UPDATE)
        (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE)
                    FLG)))
       (T (INFILECOMS? NIL TYPE (FILECOMS FILE)
                 FLG])

(UPDATEFILES
  [LAMBDA (PRLST FLST)                                   (* rmk%: "19-FEB-83 14:27")

    (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g.  LOAD, LOADFNS) involving the files in FLST began.")

    (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE))
       do (COND
                 ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE)))
                                                             (* ; 
                                                           "FILEPKGCHANGES eliminates duplicates")
                  (/replace CHANGED of TYPE with NIL))
                 (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES
                           (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST
                       first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) 

                             (* ;; "First check NIL=Nowhere.  LST:1 contains variables whose values are on the file literally.  These are `found' but not marked.  LST::1 contains all other items.")

                             (SETQ FOUND (NCONC (CAR LST)
                                                (CDR LST)
                                                FOUND))
                       do (SETQ PCHANGES (COND
                                                ((FMEMB (fetch DATEFILENAME
                                                           of (CAR (fetch FILEDATES
                                                                          of FILE)))
                                                        FLST)

                                 (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began.  Thus, by this intersection we only worry about items that were previously changed;  any items that were only changed during this operation are ignored.")

                                                 (INTERSECTION CHANGED PREVITEMS))
                                                (T CHANGED)))
                             [COND
                                ([AND PCHANGES [SETQ COMS (fetch COMSNAME
                                                             of (SETQ FILEPROP
                                                                     (LISTP (fetch FILEPROP
                                                                               of FILE]
                                      (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE]

                                 (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms")

                                 [COND
                                    ((CDR LST)               (* ; "CDR items must be distributed")
                                     [COND
                                        ((NULL (fetch TOBEDUMPED of FILEPROP))

                                         (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL")

                                         [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL
                                                                                   'NOTLISTEDFILES]
                                         (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE
                                                                              (GETTOPVAL 
                                                                                     '
                                                                                     NOTCOMPILEDFILES
                                                                                     ]
                                                             (* ; 
                                                   "Get the (possibly new) TYPE item list to smash")
                                     [COND
                                        [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED
                                                                        of FILEPROP]
                                        (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE]
                                                             (* ; 
                                                        "Now distribute items to the file property")
                                     (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP)
                                                                                   )
                                        do (/NCONC1 TYPEDPROP Y]
                                 (SETQ FOUND (NCONC (CAR LST)
                                                    (CDR LST)
                                                    FOUND] finally (/replace CHANGED
                                                                          of TYPE
                                                                          with (LDIFFERENCE
                                                                                    CHANGED FOUND])

(INFILECOMS?
  [LAMBDA (NAME TYPE COMS ONFILETYPE)                 (* ; "Edited 12-Jul-88 17:42 by MASINTER")

    (* ;; "Returns T if NAME is 'CONTAINED' in COMS.  If NAME is NIL, then value is a list of all of the functions contained in COMS.  If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.)  Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1.  while elements are the subset of NAME which are on the file in other case")

    (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS?  returns the dotted pair of (literals  . elements) where literals are those which are `literally' on the file (e.g.  (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")

    (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ")

    (PROG (VAL LITERALS ORIGFLG)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (SELECTQ ONFILETYPE
              (EDIT (SELECTQ TYPE
                        (FILEVARS (RETURN))
                        NIL))
              NIL)
          [COND
             ((LITATOM COMS)
              (SELECTQ TYPE
                  ((VARS FILEVARS)                           (* ; 
                                                           "the COMS of a file are also on it")
                       (INFILECOMSVAL COMS))
                  NIL)
              (SETQ COMS (EVALV COMS]
          (INFILECOMS COMS)
          (SETQ VAL (DREVERSE VAL))
          (RETURN (COND
                     ((EQ ONFILETYPE 'UPDATE)
                      (CONS LITERALS VAL))
                     (T VAL])

(INFILECOMTAIL
  [LAMBDA (COM FLG)                                   (* ; "Edited  2-Aug-88 02:15 by masinter")
    [SETQ COM (COND
                 ((EQ (CADR COM)
                      '*)
                  (COND
                     [(LITATOM (CADDR COM))
                      (LISTP (EVALV (CADDR COM]
                     (T [RESETVARS (DWIMLOADFNSFLG)
                                   (NLSETQ (SETQ COM (EVAL (CADDR COM]
                        COM)))
                 (T (CDR COM]
    (if (NOT FLG)
        then (for X in COM
                    do [if (AND (LISTP X)
                                        (EQ (CAR X)
                                            COMMENTFLG))
                               then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X)
                                                                        (OR (NLISTP X)
                                                                            (NEQ (CAR X)
                                                                                 COMMENTFLG]
                    finally (RETURN COM))
      else COM])

(INFILECOMS
  [LAMBDA (COMS)                                         (* rmk%: "19-FEB-83 22:17")
    (for X in COMS do (INFILECOM X])

(INFILECOM
  [LAMBDA (COM)                                       (* ; "Edited  2-Aug-88 02:27 by masinter")
    (COND
       [(NLISTP COM)
        (COND
           ((EQ TYPE 'VARS)
            (INFILECOMSVAL COM]
       ((EQ (CAR COM)
            COMMENTFLG)

        (* ;; 
"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
                                                             (* ; 
  "don't know why I should bother, but someone might want to know all of the comments on a file???")
        (COND
           ((EQ TYPE COMMENTFLG)
            (INFILECOMSVAL COM T)))
        NIL)
       (T
        (PROG ((COMNAME (CAR COM))
               (TAIL (CDR COM))
               CFN TEM)
              (COND
                 [[COND
                     ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
                      (SETQ TEM (APPLY* CFN COM (COND
                                                   ((AND (NULL ONFILETYPE)
                                                         (NOT (CL:SYMBOLP NAME)))
                                                             (* ; 
                                                "call from WHEREIS of a name which is not a symbol")
                                                    (LIST NAME))
                                                   (T NAME))
                                       TYPE ONFILETYPE)))
                     ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
                                                             (* ; "for compatability")
                      (SETQ TEM (APPLY* CFN COM TYPE NAME]
                  (COND
                     [(NLISTP TEM)
                      (COND
                         ((EQ TEM T)
                          (COND
                             ((OR (EQ NAME T)
                                  (NULL ONFILETYPE))
                              (RETFROM 'INFILECOMS? T]
                     (T (INFILECOMSVALS TEM]
                 ((LISTP TAIL)

                  (* ;; "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")

                  (SELECTQ COMNAME
                      ((PROP IFPROP) 
                           (SETQ TAIL (CDR TAIL)))
                      NIL)
                  [COND
                     ((EQ (CAR TAIL)
                          '*)
                      (COND
                         ((LITATOM (CADR TAIL))
                          (SELECTQ TYPE
                              ((VARS FILEVARS) 
                                   (INFILECOMSVAL (CADR TAIL)))
                              NIL))
                         ((AND (LISTP (CADR TAIL))
                               (EQ ONFILETYPE 'UPDATE)
                               (EQ TYPE 'VARS)
                               (EQ (CAADR TAIL)
                                   'PROGN)
                               (FMEMB (CAR (LAST (CADR TAIL)))
                                      NAME))
                          (SETQ VAL (CONS (CADR TAIL)
                                          VAL]
                  (SELECTQ COMNAME
                      ((COMS EXPORT) 
                           (INFILECOMS (INFILECOMTAIL COM T)))
                      (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM)
                                                           T)))
                      (DECLARE%:                             (* ; "skip over DECLARE: tags")
                                 [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM))
                                              (IFCDECLARE (INFILECOMTAIL COM)
                                                     (EQ TYPE 'DECLARE%:])
                      (ORIGINAL                              (* ; "dont expand macros")
                                (PROG ((ORIGFLG T))
                                      (INFILECOMS (INFILECOMTAIL COM T))))
                      ((PROP IFPROP)                         (* ; 
                                       "this currently does not handle `pseudo-types' of PROPNAMES")
                           (SELECTQ TYPE
                               (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM)
                                                              T)
                                             (CADR COM)))
                               (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
                                              (CADR COM)))
                               NIL))
                      (PROPS (RETURN (IFCPROPS COM)))
                      (MACROS (RETURN (SELECTQ TYPE
                                          (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T)
                                                        MACROPROPS))
                                          (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T)))
                                          NIL)))
                      (ALISTS                                (* ; 
                      "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")
                              (RETURN (SELECTQ TYPE
                                          (ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
                                          NIL)))
                      (P [RETURN (SELECTQ TYPE
                                     ((EXPRESSIONS P) 
                                          (INFILECOMSVALS (INFILECOMTAIL COM T)
                                                 T))
                                     (COND
                                        ((NULL ONFILETYPE)   (* ; "for WHEREIS and FILECOMSLST")
                                         (SELECTQ TYPE
                                             (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR))
                                             (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE))
                                             NIL])
                      ((ADDVARS APPENDVARS) 
                           (SELECTQ TYPE
                               (VARS [RETURN (AND (NULL ONFILETYPE)
                                                  (for X in (INFILECOMTAIL COM T)
                                                     do (INFILECOMSVAL (CAR X)
                                                                   T])
                               (ALISTS [RETURN (for X in (INFILECOMTAIL COM T)
                                                  when (EQMEMB 'ALIST (GETPROP (CAR X)
                                                                                 'VARTYPE))
                                                  do (for Z in (CDR X)
                                                            do (INFILECOMSVAL
                                                                    (LIST (CAR X)
                                                                          (CAR Z))
                                                                    T])
                               (OR (EQ TYPE COMNAME)
                                   (RETURN))))
                      ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) 
                           [RETURN (COND
                                      ((EQ TYPE 'EXPRESSIONS)
                                       (for X in (INFILECOMTAIL COM T)
                                          when (AND (LISTP X)
                                                        (NEQ (CAR X)
                                                             COMMENTFLG))
                                          do (INFILECOMSVAL (CONS 'SETQ X)
                                                        T)))
                                      ((OR (EQ TYPE 'VARS)
                                           (EQ TYPE COMNAME))(* ; 
                   "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
                                       (for X in (INFILECOMTAIL COM T)
                                          do (COND
                                                    ((LISTP X)
                                                     (AND (CAR X)
                                                          (NEQ (CAR X)
                                                               COMMENTFLG)
                                                          (INFILECOMSVAL (CAR X)
                                                                 T)))
                                                    (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS])
                      (DEFS [RETURN (for X in (INFILECOMTAIL COM T)
                                       when (EQ TYPE (CAR X)) do (INFILECOMSVALS
                                                                          (CDR X])
                      (FILES (RETURN))
                      NIL)

                  (* ;; "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")

                  (COND
                     ((EQ COMNAME TYPE)
                      (INFILECOMSVALS (INFILECOMTAIL COM T)))
                     [(AND (LISTP TYPE)
                           (FMEMB COMNAME TYPE))
                      (LET ((TYPE COMNAME))
                           (INFILECOMSVALS (INFILECOMTAIL COM T]
                     ((AND (OR (NULL CFN)
                               (AND (EQ CFN T)
                                    (NULL ONFILETYPE)))
                           (NULL ORIGFLG)
                           (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
                      (INFILECOMS (SUBPAIR (CAR TEM)
                                             (INFILECOMTAIL COM T)
                                             (CDR TEM])

(INFILECOMSVALS
  [LAMBDA (X FLG)                                     (* ; "Edited  2-Aug-88 02:21 by masinter")
    (for Y in X when (NOT (AND (LISTP Y)
                                           (EQ (CAR Y)
                                               COMMENTFLG))) do (INFILECOMSVAL Y FLG])

(INFILECOMSVAL
  [LAMBDA (X FLG)                                     (* ; "Edited 12-Jul-88 17:56 by MASINTER")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND (OR (NULL NAME)
                 (MEMBER X NAME))
             (COND
                (FLG (SETQ LITERALS (CONS X LITERALS)))
                (T (SETQ VAL (CONS X VAL]
       ((AND (EQ ONFILETYPE 'EDIT)
             FLG)                                            (* ; 
                                        "literals should not be edited as they are on the fileCOMS")
        NIL)
       ((EQ ONFILETYPE 'TYPESOF)
        (AND (COND
                ((LITATOM NAME)
                 (EQ NAME X))
                (T (EQUAL NAME X)))
             (CL:PUSHNEW TYPE VAL)))
       ([OR (EQ NAME T)
            (COND
               ((LITATOM NAME)
                (EQ NAME X))
               (T (EQUAL NAME X]
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS X VAL])

(INFILECOMSPROP
  [LAMBDA (AT PROP)                                      (* lmm "25-SEP-81 17:15")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND [OR (NULL NAME)
                 (find X in NAME suchthat (AND (EQ (CAR X)
                                                               AT)
                                                           (EQ (CADR X)
                                                               PROP]
             (SETQ VAL (CONS (LIST AT PROP)
                             VAL]
       ((OR (EQ NAME T)
            (AND (EQ (CAR NAME)
                     AT)
                 (EQ (CADR NAME)
                     PROP)))
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS (LIST AT PROP)
                        VAL])

(IFCPROPS
  [LAMBDA (COM)                                          (* bvm%: " 2-Dec-83 14:24")

(* ;;; "Examine a PROPS com for objects of specified TYPE")

    (SELECTQ TYPE
        (PROPS                                               (* ; 
                                       "the PROPS command can actually take (PROPNAME at1 at2 ...)")
               (INFILEPAIRS (INFILECOMTAIL COM)))
        (PROP                                                (* ; 
                                                "return the atoms which have any properties at all")
              (for PAIR in (INFILECOMTAIL COM) do (for ATNAME
                                                                     inside (CAR PAIR)
                                                                     do (INFILECOMSVAL ATNAME
                                                                                   ))))
        (MACROS                                              (* ; "only MACRO properties")
                (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR)
                                                                           (CDR PAIR))))
        NIL])

(IFCEXPRTYPE
  [LAMBDA (COM FN)                                       (* ; "Edited  6-Apr-87 20:20 by Pavel")

(* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN")

    (for SUBCOM in (INFILECOMTAIL COM)
       when (AND (EQ (CAR SUBCOM)
                         FN)
                     (EQ (CAR (LISTP (CADR SUBCOM)))
                         'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM))
                                                T])

(IFCPROPSCAN
  [LAMBDA (ATOMS PROPNAMES)                           (* ; "Edited  2-Aug-88 02:20 by masinter")

(* ;;; 
"Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES")

    (for AT in ATOMS WHEN (LITATOM AT) unless [COND
                                                                 [(EQ ONFILETYPE 'UPDATE)
                                                                  (COND
                                                                     (NAME (NOT (ASSOC AT NAME]
                                                                 ((LISTP NAME)
                                                                  (NEQ AT (CAR NAME]
       do (COND
                 ((EQ PROPNAMES 'ALL)
                  (for PROP in (GETPROPLIST AT) by (CDDR PROP)
                     when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP)))
                 (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])

(IFCDECLARE
  [LAMBDA (TAIL WANTDECLARE)                          (* ; "Edited  8-Jun-90 18:11 by teruuchi")
    (PROG ((TAIL TAIL))
      LP  (COND
             ((LISTP TAIL)
              [SELECTQ (CAR TAIL)
                  ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                       [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
                                                                 (CADR TAIL]
                       (SETQ TAIL (CDR TAIL)))
                  (DONTEVAL@LOAD [COND
                                    ((OR (\STKSCAN 'DOFILESLOAD)
                                         (\STKSCAN 'LOAD))
                                                  (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"")
                                     (RETURN))
                                    (WANTDECLARE (INFILECOMSVAL (CAR TAIL])
                  (COMPILERVARS (RETURN))
                  (COND
                     [(FMEMB (CAR TAIL)
                             DECLARETAGSLST)
                      (COND
                         (WANTDECLARE (INFILECOMSVAL (CAR TAIL]
                     (T (INFILECOM (CAR TAIL]
              (SETQ TAIL (CDR TAIL))
              (GO LP])

(INFILEPAIRS
  [LAMBDA (LST)                                          (* lmm " 4-DEC-78 09:51")
    (for LL in LST do (for X inside (CAR LL)
                                     do (for Y inside (CDR LL)
                                               do (INFILECOMSVAL (LIST X Y])

(INFILECOMSMACRO
  [LAMBDA (ATS PROPS)                                    (* lmm "28-SEP-78 18:35")

    (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.  --- Normally (e.g.  for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom.  However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties")

    (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE)
                                               (EVERY (PROPNAMES AT)
                                                      (FUNCTION (LAMBDA (X)
                                                                  (OR (NOT (FMEMB X MACROPROPS))
                                                                      (EQMEMB X PROPS]
                                           [SOME MACROPROPS (FUNCTION (LAMBDA (PROP)
                                                                        (EQMEMB PROP PROPS]
                                           (INFILECOMSVAL AT])
)



(* ;; "adding to a file")

(DEFINEQ

(FILES?
  [LAMBDA NIL                                            (* bvm%: "27-Oct-86 18:14")

(* ;;; 
"Display each file needing dumping, etc.  For files needing dumping, display details of why.")

    (UPDATEFILES)
    (LET (FILES CHANGES PRINTED)
         (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED
                                                                of (LISTP (fetch FILEPROP
                                                                                 of FILE]
            do (if (NOT PRINTED)
                       then (LISPXPRIN1 "To be dumped:
" T)
                             (SETQ PRINTED T))
                  (LISPXPRIN2 FILE T)
                  (LISPXPRIN1 " ...changes to " T)
                  [for CH in CHANGES bind TB
                     do (COND
                               ((LISTP CH)
                                [COND
                                   (TB (LISPXTAB TB NIL T))
                                   (T (SETQ TB (POSITION T]
                                (LISPXPRIN2 (CAR CH)
                                       T)
                                (FILES?PRINTLST (CDR CH)))
                               (T                            (* ; "old style")
                                  (LISPXPRIN2 CH T)
                                  (LISPXSPACES 1 T]
                  (LISPXTERPRI T))
         (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED "    plus "))
            do (SETQ FLG T) finally (if FLG
                                                then (OR PRINTED (LISPXPRIN1 "...to be dumped.  "
                                                                            T))
                                                      (ADDTOFILES?)))
         (if (SETQ FILES NOTCOMPILEDFILES)
             then (FILES?PRINTLST FILES "To be compiled: ")
                   (LISPXTERPRI T))
         (if (SETQ FILES NOTLISTEDFILES)
             then (FILES?PRINTLST FILES "To be listed: ")
                   (LISPXTERPRI T))
         (CL:VALUES])

(FILES?1
  [LAMBDA (TYPE FIRST)                                   (* bvm%: "27-Oct-86 18:17")

    (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.")

    (LET (STR LST)
         (COND
            ([AND (LITATOM TYPE)
                  (SETQ STR (fetch DESCRIPTION of TYPE))
                  (LISTP (SETQ LST (fetch CHANGED of TYPE]
             (AND FIRST (LISPXPRIN1 FIRST T))
             (LISPXPRIN1 '"the " T)
             (LISPXPRIN1 STR T)
             (FILES?PRINTLST LST)
             (LISPXTERPRI T)
             T])

(FILES?PRINTLST
  [LAMBDA (LST STR)                                      (* bvm%: "27-Oct-86 18:15")

    (* ;; "Print elements of LST separated by commas and indenting new lines a bunch.  If MAPRINT had a left margin arg, this would be simpler.")

    (MAPRINT LST T (OR STR ": ")
           NIL ", " [FUNCTION (LAMBDA (STR)
                                (COND
                                   ((> (+ (POSITION T)
                                          (NCHARS STR T T)
                                          3)
                                       (LINELENGTH NIL T))
                                    (LISPXTERPRI T)
                                    (LISPXPRIN1 "         " T)))
                                (LISPXPRIN2 STR T T]
           T])

(ADDTOFILES?
  [LAMBDA (NOASKSTR)                                    (* ; "Edited 10-Aug-2020 21:18 by rmk:")
                                                             (* ; "Edited 21-Aug-91 10:13 by jds")

    (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says")

    (* ;; "RMK: Eliminated literal CR's in the key list.")

    (ERSETQ
     (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS]

      (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g.  changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES")

           [COND
              (NOASKSTR (PRIN1 NOASKSTR T))
              (T (DOBE)
                 (SETQ BUFS (READP T))
                 (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go")
                                 `([Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL]
                                   [N ,(CONCAT "o" (CHARACTER (CHARCODE EOL]
                                   (%] ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
                                       EXPLAINSTRING 
                                       "] - nowhere, all items will be marked as dummy
" NOECHOFLG T))
                                 T)
                     (N (RETURN))
                     (%]                                     (* ; "Nowhere")
                         (for TYPE in FILEPKGTYPES
                            do (for NAME in (fetch (FILEPKGTYPE CHANGED)
                                                           of TYPE)
                                      do (ADDTOFILE NAME TYPE NIL)))
                         (RETURN))
                     NIL)                                    (* ; 
                              "if there was type-ahead BEFORE the askuser, then don't allow it now")
                 (COND
                    (BUFS (SETQ BUFS (COND
                                        ((READP T)
                                         (LINBUF)
                                         (SYSBUF)
                                         (SETQ BUFS (CLBUFS NIL T READBUF]
           [for TYPE STR LST in FILEPKGTYPES
              when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
                            (LISTP (SETQ LST (COND
                                                ((EQ TYPE 'VARS)
                                                 VARSCHANGES)
                                                (T (fetch (FILEPKGTYPE CHANGED) of TYPE]
              do
              (printout T "(" STR ")" T)
              (for NAME TEM FILE in LST when NAME
                 do
                 (PROG NIL
                   LP  (PRIN2 NAME T)
                       (SPACES 2 T)

                  (* ;; "if user typed ahead before entering addtofiles??  then dont allow typeahead here, because it will justgobble his earlier typeahead.")

                  (* ;; "SELCHARQ to avoid literal CR")

                       (SELCHARQ (CHCON1 (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T)))
                            (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)

                                 (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer")

                                               (DOBE)))
                                (GO LP))
                            (%]                              (* ; "Nowhere")
                                (SETQ FILE))
                            (SPACE                           (* ; "No action")
                                   (RETURN))
                            ((LF =) 
                                 (PRINT (OR (SETQ FILE LASTFILE)
                                            'Nowhere)
                                        T))
                            (SETQ FILE TEM))
                       (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
                                         (SETQ PLACE (WHATIS FILE NIL TYPE))
                                         [COND
                                            ((LITATOM PLACE) (* ; "file name")
                                             (SETQ FILE PLACE)
                                             (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                                                        NAME TYPE NEAR LISTNAME)
                                                 (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                          (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.")

                                             )
                                            ((EQ (CAR PLACE)
                                                 'Near%:)
                                             (SETQ NEAR (CADR PLACE))
                                             (COND
                                                ([SOME FILELST (FUNCTION (LAMBDA (FL)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           FL))
                                                                            NAME TYPE NEAR LISTNAME]
                                                 (PRINT (LIST 'on FILE)
                                                        T T))
                                                (T (PRINT (LIST (CADR PLACE)
                                                                'not
                                                                'found)
                                                          T T)
                                                   (ERROR!)))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE)))
                                            ([OR [UNDONLSETQ (PROGN (SAVESET
                                                                     (SETQ LISTNAME (CAR PLACE))
                                                                     (MERGEINSERT
                                                                      NAME
                                                                      (LISTP (GETTOPVAL LISTNAME))
                                                                      T)
                                                                     T
                                                                     'NOPRINT)
                                                                    (OR (SETQ FILE
                                                                         (CAR (WHEREIS NAME TYPE
                                                                                     FILELST)))
                                                                        (ERROR!]
                                                 (SOME FILELST (FUNCTION (LAMBDA (X)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           X))
                                                                            NAME TYPE NEAR LISTNAME]
                                             (PRIN1 "  value is filed on " T)
                                             (PRINT FILE T T)
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                 (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed")

                                             )
                                            (T (PRIN1 "    put list " T)
                                               (PRIN2 (CAR PLACE)
                                                      T T)
                                               (SETQ FILE
                                                (WHATIS (ASKUSER NIL NIL " on file: "
                                                                   '(("" "" EXPLAINSTRING 
                                                                         "a file name" KEYLST ()))
                                                                   T)
                                                       'FILE))
                                               (SAVESET (CAR PLACE)
                                                      (MERGEINSERT NAME
                                                             (LISTP (GETTOPVAL (CAR PLACE)))
                                                             T)
                                                      T
                                                      'NOPRINT)

                                     (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.")

                                               (ADDNEWCOM (FILECOMS FILE)
                                                      NAME TYPE (CAR PLACE)
                                                      FILE)
                                               (for F in (fetch WHENFILED of TYPE)
                                                  do (for I in (GETTOPVAL (CAR PLACE))
                                                            do (APPLY* F I TYPE FILE]
                                         (AND FILE (ADDFILE FILE))
                                         (SETQ LASTFILE PLACE)))
                           (GO LP]
           (AND BUFS (BKBUFS BUFS))
           (UPDATEFILES])

(ADDTOFILE
  [LAMBDA (NAME TYPE FILE NEAR LISTNAME)                 (* lmm "21-Nov-84 11:43")
                                                             (* ; "adds NAME to the file FILE")
    (PROG (TEM COMSNAME)
          [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T)
                         (COND
                            ((FMEMB TYPE FILELST)
                             (GETFILEPKGTYPE (swap TYPE FILE)))
                            (T (GETFILEPKGTYPE TYPE]
          (SETQ FILE (WHATIS FILE 'FILE))
          (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                     NAME TYPE NEAR LISTNAME)
              (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
          (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))
          (AND FILE (NOT (FMEMB FILE FILELST))
               (ADDFILE FILE))
          (RETURN FILE])

(WHATIS
  [LAMBDA (USERINPUT ONLY)                               (* lmm "28-Nov-84 16:49")

    (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble;  if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable")

    (PROG (TEM UCASE)
          (RETURN (COND
                     ((NULL USERINPUT)                       (* ; "nowhere")
                      NIL)
                     [(LISTP USERINPUT)
                      (COND
                         (ONLY (ERROR!))
                         (T (SELECTQ (CAR USERINPUT)
                                ((@ Near%:) 
                                     (CONS 'Near%: (CDR USERINPUT)))
                                (WHATIS (CAR USERINPUT)
                                       'LIST]
                     ([AND (NEQ ONLY 'LIST)
                           (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT)))
                                      FILELST)
                               (LISTP (GETTOPVAL (FILECOMS UCASE)))
                               (SETQ TEM (FIXSPELL UCASE NIL FILELST T]
                      TEM)
                     ((AND (NEQ ONLY 'FILE)
                           (LISTP (GETTOPVAL USERINPUT)))
                      (LIST USERINPUT))
                     ((AND (NEQ ONLY 'LIST)
                           (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE)
                                      NIL T)
                               'Y))
                      UCASE)
                     ((AND (NEQ ONLY 'FILE)
                           (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT)
                                      NIL T)
                               'Y))
                      (LIST USERINPUT))
                     (T                                      (* ; "none of above")
                        (ERROR!])

(ADDTOCOMS
  [LAMBDA (COMS NAME TYPE NEAR LISTNAME)                 (* rmk%: "10-JUN-82 22:53")

    (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms);  return NIL if unsuccessful.  If LISTNAME is given, then only insert by adding to LISTNAME.  If NEAR is given, only insert near it")

    (COND
       ((NULL COMS)
        NIL)
       [(LITATOM COMS)                                       (* ; 
      "given a name of a command;  rebind COMSNAME to current variable and try to add to its value")
        (OR [PROG ((COMSNAME COMS))
                  (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME))
                                 NAME TYPE NEAR (AND (NEQ COMS LISTNAME)
                                                     LISTNAME]
            (AND (EQ COMS LISTNAME)
                 (ADDNEWCOM COMS NAME TYPE]
       (T (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (for TAIL on COMS do (COND
                                              [(LISTP (CAR TAIL))
                                               (COND
                                                  ((ADDTOCOM (CAR TAIL)
                                                          NAME TYPE NEAR LISTNAME)
                                                   (RETURN T]
                                              (T (SELECTQ (CAR TAIL)
                                                     ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                                                          (SETQ TAIL (CDR TAIL)))
                                                     NIL])

(ADDTOCOM
  [LAMBDA (COM NAME TYPE NEAR LISTNAME)                  (* ; "Edited  2-May-87 19:04 by Pavel")
                                                             (* ; 
                        "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful")
    (PROG (TEM)
          (COND
             ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM]
              (RETURN)))
          [COND
             ((SETQ TEM (fetch ADD of (CAR COM)))
              (RETURN (COND
                         ((OR (NULL LISTNAME)
                              (INFILECOMS? LISTNAME 'FILEVARS (LIST COM)))
                          (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR))
                               (MARKASCHANGED COMSNAME 'VARS))
                          TEM]
          (RETURN
           (SELECTQ (CAR COM)
               (FNS (AND (EQ TYPE 'FNS)
                         (ADDTOCOM1 COM NAME NEAR LISTNAME)))
               ((VARS INITVARS) 
                    (COND
                       ((OR (EQ (CAR COM)
                                'VARS)
                            NEAR LISTNAME)                   (* ; 
                                  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.")
                        (SELECTQ TYPE
                            (EXPRESSIONS (COND
                                            ((EQ (CAR NAME)
                                                 'SETQ)
                                             (ADDTOCOM1 COM (CDR NAME)
                                                    NEAR LISTNAME))))
                            (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME))
                            NIL))))
               (COMS (ADDTOCOMS (COND
                                       [(EQ (CADR COM)
                                            '*)
                                        (COND
                                           ((LITATOM (CADDR COM))
                                            (CADDR COM))
                                           (T (RETURN]
                                       (T (CDR COM)))
                            NAME TYPE NEAR LISTNAME))
               (DECLARE%: (AND (OR LISTNAME NEAR)
                               (ADDTOCOMS (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     ((LITATOM (CADDR COM))
                                                      (CADDR COM))
                                                     (T (RETURN]
                                                 (T (CDR COM)))
                                      NAME TYPE NEAR LISTNAME)))
               (CL:EVAL-WHEN (AND (OR LISTNAME NEAR)
                                  (ADDTOCOMS (COND
                                                    [(EQ (CL:THIRD COM)
                                                         '*)
                                                     (COND
                                                        ((LITATOM (CL:FOURTH COM))
                                                         (CL:FOURTH COM))
                                                        (T (RETURN]
                                                    (T (CDDR COM)))
                                         NAME TYPE NEAR LISTNAME)))
               ((PROP IFPROP) 
                    (SELECTQ TYPE
                        (PROPS (COND
                                  ((EQ (CADR COM)
                                       (CADR NAME))
                                   (ADDTOCOM1 (CDR COM)
                                          (CAR NAME)
                                          NEAR LISTNAME))
                                  ((AND (EQ (CAR NAME)
                                            (CADDR COM))
                                        (NULL (CDDDR COM)))
                                   [/RPLACA (CDR COM)
                                          (UNION (MKLIST (CDR NAME))
                                                 (MKLIST (CADR COM]
                                   (MARKASCHANGED COMSNAME 'VARS)
                                   T)))
                        (MACROS (COND
                                   ([AND (for PROP inside (CADR COM)
                                            always (EQMEMB PROP MACROPROPS))
                                         (for PROP in MACROPROPS
                                            always (OR (EQMEMB PROP (CADR COM))
                                                           (NOT (GETPROP NAME PROP]

                                    (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")

                                    (ADDTOCOM1 (CDR COM)
                                           NAME NEAR LISTNAME))))
                        NIL))
               ((PROPS ALISTS) 
                    (AND (EQ TYPE (CAR COM))
                         (ADDTOCOM1
                          COM
                          (/NCONC1 (OR [ASSOC (CAR NAME)
                                              (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     [(LITATOM (CADDR COM))
                                                      (AND (OR (NULL LISTNAME)
                                                               (EQ (CADDR COM)
                                                                   LISTNAME))
                                                           (GETTOPVAL (CADDR COM]
                                                     (T (RETURN]
                                                 (T (CDR COM]
                                       (LIST (CAR NAME)))
                                 (CADR NAME))
                          NEAR LISTNAME)))
               (P (COND
                     ((AND (EQ TYPE 'EXPRESSIONS)
                           (NEQ (CAR NAME)
                                'SETQ))
                      (ADDTOCOM1 COM NAME NEAR LISTNAME))))
               (AND (EQ (CAR COM)
                        TYPE)
                    (ADDTOCOM1 COM NAME NEAR LISTNAME])

(ADDTOCOM1
  [LAMBDA (COM NAME NEAR LISTNAME)                       (* rmk%: " 3-JAN-82 22:53")
    (COND
       [(EQ (CADR COM)
            '*)                                              (* ; "add to list name")
        (AND [COND
                (LISTNAME (EQ (CADDR COM)
                              LISTNAME))
                (T (LITATOM (CADDR COM]
             (SAVESET (CADDR COM)
                    [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM]
                           (COND
                              ((AND NEAR (SETQ NEAR (MEMBER NEAR COM)))
                               (/RPLACD NEAR (CONS NAME (CDR NEAR)))
                               COM)
                              (T (MERGEINSERT NAME COM T]
                    T
                    'NOPRINT]
       ((NULL LISTNAME)                                      (* ; "add to standard com")
        [AND (NOT (MEMBER NAME (CDR COM)))
             (COND
                [(SETQ NEAR (MEMBER NEAR COM))
                 (/RPLACD NEAR (CONS NAME (CDR NEAR]
                (T (/RPLACD COM (MERGEINSERT NAME (CDR COM]
        (MARKASCHANGED COMSNAME 'VARS)
        T])

(ADDNEWCOM
  [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE)             (* rmk%: " 3-JAN-82 22:53")

    (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE.  --- if LISTNAME is given, then use it as the listname")

    (PROG (NEWCOM OLDCOM TAIL)
          (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE))
          [COND
             ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME)))
              (RETURN (SAVESET COMSNAME (LIST NEWCOM)
                             T
                             'NOPRINT]
      LP  [COND
             ((OR (NLISTP (SETQ OLDCOM (CAR TAIL)))
                  (SELECTQ (CAR OLDCOM)
                      ((LOCALVARS SPECVARS BLOCKS) 
                           T)
                      (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM)))
                      NIL))
              (/ATTACH NEWCOM TAIL))
             ((LISTP (CDR TAIL))
              (SETQ TAIL (CDR TAIL))
              (GO LP))
             (T (/RPLACD TAIL (LIST NEWCOM]
          (MARKASCHANGED COMSNAME 'VARS])

(MAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* ; "Edited  8-Apr-87 14:55 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    (PROG (TEM)

     (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname")

          (AND (LISTP NAME)
               (SETQ NAME (COPY NAME)))
          (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE))
                           (APPLY* TEM NAME TYPE LISTNAME FILE))
                      (SELECTQ TYPE
                          (PROPS [AND (NULL LISTNAME)
                                      (CONS 'PROP (CONS (COND
                                                           ((AND (LISTP (CDR NAME))
                                                                 (NULL (CDDR NAME)))
                                                            (CADR NAME))
                                                           (T (CDR NAME)))
                                                        (OR (LISTP (CAR NAME))
                                                            (LIST (CAR NAME])
                          (EXPRESSIONS [COND
                                          ((EQ (CAR NAME)
                                               'SETQ)
                                           (MAKENEWCOM (CDR NAME)
                                                  'VARS LISTNAME FILE))
                                          (T (CONS 'P (COND
                                                         (LISTNAME (LIST '* LISTNAME))
                                                         (T (LIST NAME])
                          NIL)
                      (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE])

(DEFAULTMAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* lmm "20-OCT-82 22:48")
    (COND
       ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST)
                 (fetch MACRO of TYPE)
                 (fetch GETDEF of TYPE)))
        (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION
                                                                            of TYPE)
                                                                         TYPE)
               T))
       ((NULL DEFAULTCOMHASFILEFLG)                          (* ; "disable FOOFNS FOOVARS junk")
        (LIST TYPE NAME))
       ((EQ FILE T)                                          (* ; 
                                                           "FILE=T only when called from SHOWDEF")
        (LIST TYPE NAME))
       ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE))
                                      (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME))
                                             T)
                                      T
                                      'NOPRINT]              (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items")
        (LIST TYPE '* LISTNAME))
       (T (LIST TYPE NAME])
)

(RPAQ? DEFAULTCOMHASFILEFLG )

(ADDTOVAR MARKASCHANGEDFNS )
(DEFINEQ

(MERGEINSERT
  [LAMBDA (NEW LST ONEFLG)                               (* lmm "30-Jun-86 18:11")

    (* ;; "searches LST to find the most reasonable place to insert NEW.  Does nothing if ONEFLG is T and NEW is already a member of LST")

    (COND
       ((AND ONEFLG (MEMBER NEW LST))
        LST)
       ((LISTP NEW)
        (/NCONC1 LST NEW))
       (T (PROG ((N 0)
                 LST1 PLACE TEM)
                (SETQ LST1 LST)
            LP  

           (* ;; "finds the function with the longest leading common substring.  The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.")

                (COND
                   ((NULL LST1)
                    (GO OUT))
                   ((OR (LISTP (CAR LST1))
                        (SETQ TEM (STRPOS (CAR LST1)
                                         NEW 1 NIL T T)))

                    (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE")

                    (SETQ PLACE LST1)
                    (GO OUT))
                   ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1)
                                                NEW))
                           N)
                    (SETQ N TEM)
                    (SETQ PLACE LST1)))
                (SETQ LST1 (CDR LST1))
                (GO LP)
            OUT (SETQ TEM (CAR PLACE))
                (OR [SOME (OR PLACE LST)
                          (FUNCTION (LAMBDA (X LST)
                                      (COND
                                         ([OR (ALPHORDER NEW X)
                                              (AND PLACE (NOT (ALPHORDER TEM X]

                                 (* ;; "for example, if the FNS list is something like (...  FOO FOO1 ...) where the ...  may or may not be in order, e.g.  (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.")

                                          (/ATTACH NEW LST))
                                         (T (SETQ TEM X)
                                            NIL]
                    (SETQ LST (/NCONC1 LST NEW)))
                (RETURN LST])

(MERGEINSERT1
  [LAMBDA (X Y)                                          (* rmk%: "24-MAY-82 00:05")

    (* ;; "value is the number of leading characters of X and Y that agree.")

    (PROG ((N 1)
           C1 C2)
      LP  [COND
             ((OR (NULL (SETQ C1 (NTHCHARCODE X N)))
                  (NULL (SETQ C2 (NTHCHARCODE Y N)))
                  (NEQ C1 C2))
              (RETURN (SUB1 N]
          (SETQ N (ADD1 N))
          (GO LP])
)



(* ;; 
"RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file"
)


(RPAQ ADDTOFILEKEYLST
      `(("[" "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" NOECHOFLG T)
        (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T)
        (,(CHARACTER (CHARCODE LF))
         "" EXPLAINSTRING "{line-feed} - same as previous response" NOECHOFLG T)
        (" " ,(CONCATCODES (LIST (CHARCODE SPACE)
                                 (CHARCODE EOL)))
             EXPLAINSTRING "{space} - no action" NOECHOFLG T)
        ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
             EXPLAINSTRING
             ,(CONCAT "] - nowhere, item is marked as a dummy" (CHARACTER (CHARCODE EOL)))
             NOECHOFLG T)
        ["(" "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
             (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE))
                                  ,(CHARACTER (CHARCODE EOL]
                 RETURN
                 (CDR ANSWER]
        (@ "Near: " EXPLAINSTRING "@ other-item   -- put the item near the other item" NOECHOFLG T 
           KEYLST (( "" CONFIRMFLG [,(CHARACTER (CHARCODE EOL]
                      RETURN ANSWER)))
        [,(CHARACTER (CHARCODE CR))
         "" RETURN ,(CHARACTER (CHARCODE SPACE]
        ("" "File name: " EXPLAINSTRING "a file name" KEYLST ())))

(RPAQQ LASTFILE NIL)



(* ;; "deleting an item from a file")

(DEFINEQ

(DELFROMFILES
  [LAMBDA (NAME TYPE FILES)                              (* rmk%: " 6-MAR-82 13:16")

    (* ;; "Eliminates NAME as an item of type TYPE in COMS.")

    (PROG (COMS)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (RETURN (for FILE inside (OR FILES FILELST)
                     when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE))
                                            NAME TYPE)
                                  (COND
                                     ((INFILECOMS? NAME TYPE COMS)
                                      (printout T "(could not delete " NAME " from " FILE ")" T))))
                     collect (for FN in (fetch WHENUNFILED of TYPE)
                                    do (APPLY* FN NAME TYPE FILE))
                           FILE])

(DELFROMCOMS
  [LAMBDA (COMS NAME TYPE)                               (* bvm%: " 1-Oct-86 22:02")

    (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list).  Returns T if it does anything")

    (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.")

    (COND
       [(LITATOM COMS)
        (LET ((COMSNAME COMS))
             (DECLARE (SPECVARS COMS))
             (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME)))
                  (DELFROMCOMS COMS NAME TYPE]
       (T (PROG (DONE)
                (SETQ TYPE (GETFILEPKGTYPE TYPE))
            LP  (COND
                   ((NLISTP COMS)
                    (RETURN DONE)))
                [COND
                   ((LISTP (CAR COMS))
                    (SELECTQ (DELFROMCOM (CAR COMS)
                                    NAME TYPE)
                        (ALL (/RPLNODE2 COMS (CDR COMS))
                             (SETQQ DONE ALL)
                             (GO LP))
                        (NIL)
                        (SETQ DONE T)))
                   (T (SELECTQ (CAR COMS)
                          ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                               (SETQ COMS (CDR COMS)))
                          (COND
                             ((AND (EQ TYPE 'VARS)
                                   (EQ NAME (CAR COMS)))
                              (/RPLNODE2 COMS (CDR COMS))
                              (SETQ DONE T)
                              (GO LP]
                (SETQ COMS (CDR COMS))
                (GO LP])

(DELFROMCOM
  [LAMBDA (COM NAME TYPE)                                (* ; "Edited  2-May-87 19:02 by Pavel")
                                                             (* ; "Tries to delete NAME from COM")
    (PROG (TEM VAR NEW)
          (COND
             ((SETQ TEM (fetch DELETE of (CAR COM)))
              (AND (SETQ TEM (APPLY* TEM COM NAME TYPE))
                   (MARKASCHANGED COMSNAME 'VARS))
              (RETURN TEM)))
          (RETURN (SELECTQ (CAR COM)
                      ((DECLARE%: COMS) 
                           (DELFROMCOMS (COND
                                               [(EQ (CADR COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CADDR COM))
                                                    (CADDR COM))
                                                   (T (RETURN]
                                               (T (CDR COM)))
                                  NAME TYPE))
                      ((CL:EVAL-WHEN) 
                           (DELFROMCOMS (COND
                                               [(EQ (CL:THIRD COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CL:FOURTH COM))
                                                    (CL:FOURTH COM))
                                                   (T (RETURN]
                                               (T (CDDR COM)))
                                  NAME TYPE))
                      ((ALISTS PROPS) 
                           (AND (EQ TYPE (CAR COM))
                                (COND
                                   ((EQ (CADR COM)
                                        '*)
                                    (COND
                                       ([AND (LITATOM (SETQ VAR (CADDR COM)))
                                             (SETQ TEM (ASSOC (CAR NAME)
                                                              (GETTOPVAL VAR)))
                                             (NEQ (CDR TEM)
                                                  (SETQ TEM (REMOVEITEM (CADR NAME)
                                                                   (CDR TEM]
                                        (SAVESET VAR TEM T 'NOPRINT)
                                        T)))
                                   ([AND [CDR (SETQ TEM (ASSOC (CAR NAME)
                                                               (CDR COM]
                                         (NEQ (CDR TEM)
                                              (SETQ NEW (REMOVEITEM (CADR NAME)
                                                               (CDR TEM]
                                    (/RPLACD TEM NEW)
                                    (MARKASCHANGED COMSNAME 'VARS)
                                    T))))
                      (BLOCKS 
                              (* ;; "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")

                              [AND (EQ TYPE 'FNS)
                                   (for BLOCK in (INFILECOMTAIL COM T)
                                      do (AND (MEMB NAME BLOCK)
                                                  (/DREMOVE NAME BLOCK))
                                            (for X in BLOCK
                                               when (AND (LISTP X)
                                                             (MEMB NAME (CDR X)))
                                               do (/RPLACD X (REMOVE NAME (CDR X])
                      ((PROP IFPROP) 
                           [SELECTQ TYPE
                               (PROPS (RETURN (COND
                                                 ((EQ (CADR COM)
                                                      (CADR NAME))
                                                  (DELFROMCOM1 (CDR COM)
                                                         (CAR NAME)))
                                                 ((AND (EQMEMB (CADR NAME)
                                                              (CADR COM))
                                                       [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM]
                                                       (EQ (CAR TEM)
                                                           (CAR NAME)))
                                                  [/RPLACA (CDR COM)
                                                         (REMOVE (CADR NAME)
                                                                (MKLIST (CADR COM]
                                                  (MARKASCHANGED COMSNAME 'VARS)
                                                  T))))
                               (COND
                                  ([for PROP inside (CADR COM)
                                      always (EQ TYPE (GETPROP PROP 'PROPTYPE]
                                   (DELFROMCOM1 (CDR COM)
                                          NAME])
                      ((RECORDS INITRECORDS SYSRECORDS) 
                           (AND (EQ TYPE 'RECORDS)
                                (DELFROMCOM1 COM NAME)))
                      (P (AND (EQ TYPE 'EXPRESSIONS)
                              (DELFROMCOM1 COM NAME)))
                      ((VARS INITVARS) 
                           (AND (EQ TYPE 'VARS)
                                (DELFROMCOM1 COM NAME T)))
                      (AND (EQ TYPE (CAR COM))
                           (DELFROMCOM1 COM NAME])

(DELFROMCOM1
  [LAMBDA (COM NAME FLG)                                 (* rmk%: "10-JUN-82 22:44")

    (* ;; 
  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed")

    (LET (TEM VAL)
         (COND
            ((EQ (CADR COM)
                 '*)
             (COND
                ([AND (LITATOM (SETQ TEM (CADDR COM)))
                      (NEQ (SETQ VAL (GETTOPVAL TEM))
                           (SETQ VAL (REMOVEITEM NAME VAL FLG]
                 (SAVESET TEM VAL T 'NOPRINT)
                 T)))
            ((NEQ (CDR COM)
                  (SETQ TEM (REMOVEITEM NAME (CDR COM)
                                   FLG)))
             (/RPLACD COM TEM)
             (MARKASCHANGED COMSNAME 'VARS)
             T])

(REMOVEITEM
  [LAMBDA (X LST FLG)                                    (* ; "Edited 25-May-88 17:52 by drc:")
                                                             (* lmm "10-FEB-78 17:29")

    (* ;; 
  "returns a subset of LST with X deleted;  if FLG is set, also remove elements whose CAR is X")

    (COND
       [[OR (MEMBER X LST)
            (AND FLG (SOME LST (FUNCTION (LAMBDA (Y)
                                           (EQUAL (CAR (LISTP Y))
                                                  X]
        (SUBSET LST (FUNCTION (LAMBDA (Y)
                                (AND (NOT (EQUAL Y X))
                                     (OR (NOT FLG)
                                         (NLISTP Y)
                                         (NOT (EQUAL (CAR Y)
                                                     X]
       (T LST])

(MOVETOFILE
  [LAMBDA (TOFILE NAME TYPE FROMFILE)                    (* rmk%: "18-OCT-79 19:51")
                                                             (* ; "To move items between files")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    [COND
       ((OR (EQ TYPE 'FNS)
            FROMFILE)                                        (* ; 
       "FNS definition can reside on file if LOADFNS was done.  This guarantees that it is loaded.")
        (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM]
    (AND (EQ TYPE 'FNS)
         (MARKASCHANGED NAME TYPE))                      (* ; 
                                                   "FNS won't get dumped unless they are `changed'")
    (DELFROMFILES NAME TYPE FROMFILE)
    (ADDTOFILE NAME TYPE TOFILE])
)

(MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)

(MOVD? 'MOVETOFILE 'MOVEITEM NIL T)

(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)



(* ; "functions for doing things and marking them changed and auxiliary functions")

(DEFINEQ

(SAVEPUT
  [LAMBDA (ATM PROP VAL)                                 (* lmm " 7-May-84 16:56")

    (* ;; "analogous to SAVESET but also marks changed property lists;  LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT")

    [COND
       ((NOT (LITATOM ATM))
        (ERRORX (LIST 14 ATM]
    (PROG ((X (GETPROPLIST ATM))
           X0 TEM OLDFLG)
      LOOP
          (COND
             ((NLISTP X)
              (COND
                 ((AND (NULL X)
                       X0)                                   (* ; 
                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")
                  (SETQ TEM (LIST PROP VAL))
                  (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                        LISPXHIST))
                  (FRPLACD (CDR X0)
                         TEM)
                  (GO RET)))

              (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")

              )
             ((NLISTP (CDR X))

              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning.")

              )
             [(EQ (CAR X)
                  PROP)
              (SETQ OLDFLG (NEQ (EQUALN (CADR X)
                                       VAL 400)
                                T))                          (* ; "i.e. it probably changed")
              (/RPLACA (CDR X)
                     VAL)
              (COND
                 ((NOT OLDFLG)
                  (GO RET1))
                 (T (OR (EQ DFNFLG T)
                        (LISPXPRINT (LIST 'new PROP 'property 'for ATM)
                               T T))
                    (GO RET]
             (T (SETQ X (CDDR (SETQ X0 X)))
                (GO LOOP)))
          [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM]
          (SETPROPLIST ATM TEM)
          (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                LISPXHIST))
      RET (MARKASCHANGED (LIST ATM PROP)
                 'PROPS
                 (NOT OLDFLG))
      RET1
          (AND ADDSPELLFLG (ADDSPELL ATM 0))
          (RETURN VAL])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
    (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT))
)
(DEFINEQ

(UNMARKASCHANGED
  [LAMBDA (NAME TYPE)                                    (* JonL "24-Jul-84 19:59")

    (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties.  Value is name if anything is done")

    (PROG (ANYFLG)
          (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE
                                                                          TYPE
                                                                          'TYPE]
             while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL)
                                                               (SETQ ANYFLG T))
          [for F TAIL PROP TYPEDPROP in FILELST
             when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP
                                                    (ASSOC TYPE (fetch TOBEDUMPED
                                                                   of (SETQ PROP
                                                                           (fetch FILEPROP
                                                                              of F]
             do (SETQ ANYFLG T)
                   (COND
                      ((SETQ TAIL (REMOVE (CAR TAIL)
                                         (CDR TYPEDPROP)))
                       (/RPLACD TYPEDPROP TAIL))
                      (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP
                                                                              (fetch TOBEDUMPED
                                                                                 of PROP]
          (RETURN (AND ANYFLG NAME])

(PREEDITFN
  [LAMBDA (ATM TYPE EDITCHANGES)                         (* rmk%: "18-FEB-82 21:49")
                                                             (* ; 
                                           "EDITL is advised to call this before editing something")
    (AND FILEPKGFLG (SELECTQ TYPE
                        (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                   (CONS))
                                                            CLISPARRAY))
                                      (for X in (GETPROPLIST ATM)
                                         do (OR (NLISTP X)
                                                    (GETHASH X CLISPARRAY)
                                                    (PUTHASH X (CONS (CAR X)
                                                                     (CDR X))
                                                           CLISPARRAY]

                                 (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made")

                                 [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS)
                                                      EDITCHANGES
                                                      (APPEND (GETPROPLIST ATM])
                        (VARS [COND
                                 ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE))
                                  [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                    (CONS))
                                                             CLISPARRAY))
                                       (for X in (EVALV ATM)
                                          do (OR (NLISTP X)
                                                     (GETHASH X CLISPARRAY)
                                                     (PUTHASH X (CONS (CAR X)
                                                                      (CDR X))
                                                            CLISPARRAY]
                                  (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS)
                                                       EDITCHANGES
                                                       (for X in (EVALV ATM)
                                                          collect (CAR X])
                        NIL])

(POSTEDITPROPS
  [LAMBDA (EDITCHANGES OLDPROPS)                         (* rmk%: "18-FEB-82 21:50")
                                                             (* ; "was RESETSAVE'd from PREEDITFN")
    (PROG (OV FOUNDCHANGE)
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP)
                 when (for OLDPROP on OLDPROPS by (CDDR OLDPROP)
                             do (COND
                                       ((EQ (CAR OLDPROP)
                                            (CAR NEWPROP))   (* ; "Found the property")
                                        [AND (EQ (CADR OLDPROP)
                                                 (CADR NEWPROP))
                                             (COND
                                                ((NLISTP (CADR OLDPROP))
                                                             (* ; "value is same")
                                                 (RETURN))
                                                ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP)
                                                                                 CLISPARRAY))
                                                      (EQ (CAADR NEWPROP)
                                                          (CAR OV))
                                                      (EQ (CDADR NEWPROP)
                                                          (CDR OV)))
                                                 (PUTHASH (CADR NEWPROP)
                                                        NIL CLISPARRAY)
                                                             (* ; 
                                         "value has been edited (CLISPARRAY translation went away)")
                                                 (RETURN]
                                        (RETURN T))) finally 
                                                             (* ; "didn't find the property")
                                                           (RETURN T))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 (CAR NEWPROP))
                               'PROPS NIL)
                       (SETQ FOUNDCHANGE T))
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])

(POSTEDITALISTS
  [LAMBDA (EDITCHANGES OLDTOKENS)                        (* rmk%: " 4-JAN-82 10:14")
    (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES]
                                                             (* ; 
                                                           "called after an ALIST has been edited")
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 X)
                               'ALISTS NIL)
                       (SETQ FOUNDCHANGE T))
              [for NEWENTRY in NEWENTRIES
                 do (COND
                           ([AND (LISTP NEWENTRY)
                                 (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY))
                                           (EQ (CAR NEWENTRY)
                                               (CAR OV))
                                           (EQ (CDR NEWENTRY)
                                               (CDR OV]
                            (PUTHASH NEWENTRY NIL CLISPARRAY)
                            (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                     (CAR NEWENTRY))
                                   'ALISTS NIL)
                            (SETQ FOUNDCHANGE T]
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])
)

(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
                       (PUTPROP . SAVEPUT))



(* ; "sub-functions for file package commands & types")

(DEFINEQ

(ALISTS.GETDEF
  [LAMBDA (NAME TYPE OPTIONS)                            (* Pavel " 7-Oct-86 17:24")
    (AND (LISTP NAME)
         (CL:SYMBOLP (CAR NAME))
         (LET [(ASSOCIATION (ASSOC (CADR NAME)
                                   (GETTOPVAL (CAR NAME]
              (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME)
                                     ASSOCIATION])

(ALISTS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm "16-OCT-78 20:02")
                                                             (* ; 
                                          "called by MARKASCHANGED when an ALIST entry has changed")
    (PROG [(VARTYPE (GETPROP (CAR NAME)
                           'VARTYPE]
          (AND (LISTP VARTYPE)
               (EQ (CAR VARTYPE)
                   'ALIST)
               (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME)
                                              (CADR VARTYPE)
                                              NEWFLG])

(CLEARCLISPARRAY
  [LAMBDA (NAME TYPE REASON)
    (DECLARE (SPECVARS NAME TYPE REASON))            (* lmm "14-Aug-84 15:03")
    (AND CLISPARRAY (MAPHASH CLISPARRAY (COND
                                           [(EQ TYPE 'I.S.OPRS)
                                            (FUNCTION (LAMBDA (TRAN FORM)
                                                        (AND (MEMB NAME FORM)
                                                             (PUTHASH FORM NIL CLISPARRAY]
                                           (T                (* ; "MACRO changed")
                                              (FUNCTION (LAMBDA (TRAN FORM)
                                                          (COND
                                                             ((OR (EQ NAME (CAR FORM))
                                                                  (EQ (CAR (GETPROP (CAR FORM)
                                                                                  'CLISPWORD))
                                                                      'CHANGETRAN))
                                                              (PUTHASH FORM NIL CLISPARRAY])

(EXPRESSIONS.WHENCHANGED
  [LAMBDA (EXPR)                                         (* ; "Edited  6-Apr-87 20:21 by Pavel")
    (SELECTQ (CAR EXPR)
        ((SETQ SETQQ) 
             (UNMARKASCHANGED (CADR EXPR)
                    'VARS))
        ((PROGN PROG) 
             (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X)))
        NIL])

(MAKEALISTCOMS
  [NLAMBDA X                                             (* rmk%: "14-OCT-83 13:34")

    (* ;; "make command to dump prettydefmacros")

    (LIST
     (CONS 'ADDVARS
           (for PR in X
              join (for ALISTNAME inside (CAR PR)
                          collect (CONS ALISTNAME
                                            (for ATNAME inside (CDR PR) bind ENTRY
                                               when (SETQ ENTRY
                                                         (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME))
                                                             (PROGN (LISPXPRINT (LIST 'no ATNAME
                                                                                      'entry
                                                                                      'on ALISTNAME)
                                                                           T T)
                                                                    NIL))) collect ENTRY])

(MAKEFILESCOMS
  [NLAMBDA FILES                                         (* JonL "12-FEB-83 19:02")

    (* ;; "This scans the command just to warn the user about any errors.  Must match up with the big SELECTQ in FILESLOAD NIL")

    [for FILE in FILES
       do
       (OR
        (LITATOM FILE)
        (while (LISTP FILE)
           do (SELECTQ (CAR (OR (LISTP FILE)
                                    (RETURN)))
                      ((LOADCOMP LOADFROM))
                      (FROM (pop FILE)
                            (if (OR (EQ (CAR FILE)
                                            'VALUEOF)
                                        (if (AND (EQ (CAR FILE)
                                                         'VALUE)
                                                     (EQ (CADR FILE)
                                                         'OF))
                                            then (pop FILE)))
                                then (pop FILE)))
                      ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR))
                      (OR (FMEMB (CAR FILE)
                                 LOADOPTIONS)
                          (PRINT (CONS (CAR FILE)
                                       '(-- unrecognized FILES option))
                                 T)))
                 (pop FILE]
    (CONS 'FILESLOAD FILES])

(MAKELISPXMACROSCOMS
  [NLAMBDA X                                             (* lmm " 5-SEP-78 23:15")
    (PROG (TEM TEM2)
          (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                   LISPXHISTORYMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXHISTORYMACROS TEM)))
                                                       (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                          LISPXMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXMACROS TEM]
                        (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z LISPXCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2]
                                          (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z HISTORYCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2])

(MAKEPROPSCOMS
  [NLAMBDA X                                             (* lmm "26-FEB-78 17:10")

    (* ;; "make command to dump PROPS")

    (for PAIR in X collect (CONS 'PROP (CONS (COND
                                                            ((AND (LISTP (CDR PAIR))
                                                                  (NULL (CDDR PAIR)))
                                                             (CADR PAIR))
                                                            (T (CDR PAIR)))
                                                         (OR (LISTP (CAR PAIR))
                                                             (LIST (CAR PAIR])

(MAKEUSERMACROSCOMS
  [NLAMBDA X                                             (* rmk%: " 3-JAN-82 23:20")
    (PROG (TEM)
          [COND
             [X (for Y in X
                   do (OR (FASSOC Y USERMACROS)
                              (FASSOC Y EDITMACROS)
                              (LISPXPRINT (CONS Y '(-- no entry on USERMACROS))
                                     T T]
             (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR))
                               X]
          (RETURN (LIST (CONS 'ADDVARS
                              (NCONC (for VAR in '(USERMACROS EDITMACROS)
                                        when (SETQ TEM (for Y in (GETTOPVAL VAR)
                                                              when (FMEMB (CAR Y)
                                                                              X) collect Y))
                                        collect (CONS VAR TEM))
                                     (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS 
                                                                 DONTSAVEHISTORYCOMS)
                                        when [SETQ TEM
                                                  (SUBSET (GETTOPVAL LST)
                                                         (FUNCTION (LAMBDA (Y)
                                                                     (OR (FMEMB Y X)
                                                                         (AND (LISTP Y)
                                                                              (FMEMB (CAR Y)
                                                                                     X]
                                        collect (CONS LST TEM])

(PROPS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm " 7-SEP-78 22:08")
    (PROG [(PROPTYPE (GETPROP (CADR NAME)
                            'PROPTYPE]
          (COND
             [PROPTYPE (RETFROM 'MARKASCHANGED (COND
                                                  ((NEQ PROPTYPE 'IGNORE)
                                                   (MARKASCHANGED (CAR NAME)
                                                          PROPTYPE NEWFLG]
             (T (SELECTQ (CADR NAME)
                    (CLISPWORD (CLEARCLISPARRAY (CAR NAME)))
                    NIL])

(FILEGETDEF.LISPXMACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:12")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (EQ FIRST 'ADDTOVAR)
                                                                   (MEMB SECOND '(LISPXMACROS 
                                                                                        LISPXCOMS))
                                                                   T]
                when (SELECTQ (CADR X)
                             (LISPXMACROS                    (* ; 
                      "Rebuild the expressions cause there might be other elements in the ADDTOVAR")
                                          (AND (SETQ X (ASSOC NAME (CDDR X)))
                                               (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X))))
                             (LISPXCOMS [COND
                                           ((MEMB NAME (CDDR X))
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME)))
                                           ((SETQ X (ASSOC NAME (CDDR X)))
                                                             (* ; "For synonym pairs")
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X])
                             NIL) collect X])

(FILEGETDEF.ALISTS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'ADDTOVAR)
                                                          (EQ SECOND (CAR NAME]
       when (SETQ X (ASSOC (CADR NAME)
                               (CDDR X))) collect X
       finally (RETURN (COND
                              ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.RECORDS
  [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND)            (* lmm "26-Jun-86 15:56")
    (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                              (AND (MEMB FIRST CLISPRECORDTYPES)
                                                   (OR (EQ SECOND NAME)
                                                       (AND (MEMB SECOND '(%( %[))
                                                            (PROGN (RATOM)
                                                                   (RATOM)
                                                                   (RATOM)
                                                                   (EQ NAME (RATOM]
         (if (EQ (CAAR VAL)
                     'NOT-FOUND%:)
             then NOTFOUND
           elseif (CDR VAL)
             then (CONS 'PROGN VAL)
           else (CAR VAL])

(FILEGETDEF.PROPS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'PUTPROPS)
                                                          (EQ SECOND (CAR NAME]
       join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL)
                                                                              (CADR NAME))
                   join (LIST (CAR TAIL)
                                  (CADR TAIL)))
       finally (RETURN (COND
                              ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.MACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "28-May-86 09:51")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (FMEMB FIRST '(PUTPROPS DEFMACRO))
                                                                   (EQ SECOND NAME]
                join (if (EQ (CAR X)
                                     'DEFMACRO)
                             then (LIST X)
                           else (for TAIL on (CDDR X) by (CDDR TAIL)
                                       when (FMEMB (CAR TAIL)
                                                       MACROPROPS) collect (LIST 'PUTPROPS
                                                                                     (CADR X)
                                                                                     (CAR TAIL)
                                                                                     (CADR TAIL])

(FILEGETDEF.VARS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:14")
    (for X in (LOADFNS NIL SOURCE 'GETDEF NAME)
       do (SELECTQ (CAR X)
                  ((RPAQQ SETQQ) 
                       (RETURN (CADDR X)))
                  ((RPAQ SETQ RPAQ?) 
                       (RETURN (EVAL (CADDR X))))
                  NIL) finally (RETURN 'NOBIND])

(FILEGETDEF.FNS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: "29-Aug-86 22:30")
    (LET (MAP ENV)
         (COND
            [(AND (EQMEMB 'FAST OPTIONS)
                  (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
                                (GET-ENVIRONMENT-AND-FILEMAP SOURCE))
                         MAP))
             (for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME
                                                                                      (CDDR PAIR]
                do [OR (OPENP SOURCE)
                           (RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
                                                                             'OLD]
                      (SETFILEPTR SOURCE MAPLOC)
                      (RETURN (WITH-READER-ENVIRONMENT ENV
                                  [COND
                                     ((EQMEMB 'ARGLIST OPTIONS)
                                      (RATOM SOURCE)
                                      (READ SOURCE)
                                      (RATOM SOURCE)
                                      (LIST (READ SOURCE)
                                            (READ SOURCE)))
                                     (T (CADR (READ SOURCE])]
            (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])

(FILEPKGCOMS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 11:29")
    (PROG (COM TYP)
          [SELECTQ (CAR (LISTP DEFINITION))
              (COM (SETQ COM (CDR DEFINITION)))
              (TYPE (SETQ TYP (CDR DEFINITION)))
              (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION)))
                     (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION]

     (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE")

          (for I in COM by (CDDR I) do (SELECTQ I
                                                           ((ADD DELETE MACRO CONTENTS CONTAIN COM))
                                                           (ERROR I 
                                                                  "not file package command property"
                                                                  )))
                                                             (* ; 
                                                   "COM merely adds to spelling list, for builtins")
          [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS)
                                             (LISTGET COM 'CONTAIN]
                                                             (* ; "Until CONTAIN is de-documented.")
          (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP
                                                                         (LISTGET COM PROP)))
          [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS)
                                                           (SELECTQ I
                                                               ((DESCRIPTION TYPE))
                                                               (ERROR I 
                                                             "not file package type/command property"
                                                                      ]
                                                             (* ; 
                                                  "TYPE merely adds to spelling list, for builtins")
          (for PROP in (UNION '(DESCRIPTION TYPE)
                                      FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP
                                                                      (LISTGET TYP PROP])

(FILES.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 17:13")
    (PROGN (PUTDEF (FILECOMS NAME)
                  'VARS
                  (CAR DEFINITION)
                  REASON)                                    (* ; "DEFINE THE COMS")
           (ADDFILE NAME)                                (* ; 
                                                           "MAKE SURE IT IS A FILE PACKAGE ENTITY")
           [/replace TOBEDUMPED of (fetch FILEPROP of NAME)
                                          (FILEPKG.MERGECHANGES (CADR DEFINITION)
                                                 (fetch TOBEDUMPED of (fetch FILEPROP
                                                                                 of NAME]
           (OR (fetch FILEDATES of NAME)
               (/replace FILEDATES of NAME with (CADDR DEFINITION])

(VARS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "29-Jul-85 20:59")
    (/SETTOPVAL NAME DEFINITION T])

(FILES.WHENCHANGED
  [LAMBDA (NAME TYPE REASON)
    (MARKASCHANGED (FILECOMS NAME)
           'VARS REASON])
)

(ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO)

(ADDTOVAR SYSPROPS PROPTYPE)

(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)

(PUTPROPS SUBR PROPTYPE IGNORE)

(PUTPROPS LIST PROPTYPE IGNORE)

(PUTPROPS CODE PROPTYPE IGNORE)

(PUTPROPS FILEDATES PROPTYPE IGNORE)

(PUTPROPS FILE PROPTYPE IGNORE)

(PUTPROPS FILEMAP PROPTYPE IGNORE)

(PUTPROPS EXPR PROPTYPE FNS)

(PUTPROPS VALUE PROPTYPE VARS)

(PUTPROPS COPYRIGHT PROPTYPE FILES)

(PUTPROPS FILETYPE PROPTYPE FILES)

(PUTPROPS BAKTRACELST VARTYPE ALIST)

(PUTPROPS BREAKMACROS VARTYPE ALIST)

(PUTPROPS COMPILETYPELST VARTYPE ALIST)

(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))

(PUTPROPS ERRORTYPELST VARTYPE ALIST)

(PUTPROPS FONTDEFS VARTYPE ALIST)

(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))

(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)

(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)

(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)

(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))



(* ; "Define the commands below AFTER the various properties have been established.")


(ADDTOVAR USERMACROS
          (M NIL (MAKE FILE FILE))
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITMACROS
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITCOMSA M)

(ADDTOVAR EDITCOMSL M)



(* ; "GETDEF methods")

(DEFINEQ

(RENAME
  [LAMBDA (OLD NEW TYPES FILES METHOD)               (* JonL "24-Jul-84 20:01")
    (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD)))

     (* ;; "special kludge: change the callers BEFORE if we are changing a field;  this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message")

          [for TYPE inside TYPES when (NEQ TYPE 'FIELDS)
             do (COPYDEF OLD NEW TYPE NIL (COND
                                                     ((EQ TYPE 'VARS)
                                                      'NOERROR]
          (CHANGECALLERS OLD NEW TYPES FILES METHOD)
          [for TYPE inside TYPES do (COND
                                                   ((AND (EQ TYPE 'FIELDS)
                                                         (HASDEF OLD 'FIELDS))

                                 (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file.  Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.")

                                                    (COPYDEF OLD NEW 'FIELDS))
                                                   (T (DELDEF OLD TYPE]
          (RETURN NEW])

(CHANGECALLERS
  [LAMBDA (OLD NEW AS-TYPES FILES METHOD)            (* ; "Edited  6-Dec-86 01:25 by lmm")
    (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES))
           REL TEM EDITCOMS FNS)
          (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD))
          [SETQ EDITCOMS
           (LIST (COND
                    [(OR (EQMEMB 'CAREFUL METHOD)
                         (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES))
                                (printout T "Warning --" OLD " is also defined as " TEM T)))

                     (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename.  Y means do it, No means skip, anything else goes into TTY.")

                     (SUBPAIR '(OLD NEW)
                            (LIST OLD NEW)
                            '(BIND (LPQ (F OLD N)
                                            (MARK %#1)
                                            (ORR (1 !0 P)
                                                 NIL)
                                            (MARK %#2)
                                            (COMS (SELECTQ (ASKUSER NIL NIL "   Replace ? "
                                                                  '((Y "Yes
")
                                                                    (N "No
")
                                                                    (%
 "")
                                                                    (%  "")
                                                                    (%
 "")
                                                                    (& ""))
                                                                  NIL NIL '(NOECHOFLG T))
                                                      (Y '(R1 OLD NEW))
                                                      (N NIL)
                                                      'TTY%:))
                                            (MARK %#3)
                                            (IF (EQ (%## (\ %#3))
                                                        (%## (\ %#2)))
                                                   ((\ %#1))
                                                   NIL]
                    (T (LIST 'R OLD NEW]
          (SELECTQ (COND
                      ((AND (EQMEMB 'MASTERSCOPE METHOD)
                            MSDATABASELST
                            (for TYPE inside AS-TYPES
                               do [COND
                                         ((SETQ TEM (SELECTQ TYPE
                                                        ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 
                                                             'CALL)
                                                        (MACROS '(CALL DIRECTLY))
                                                        ((VARS VARIABLES) 
                                                             '(USE OR BIND))
                                                        ((RECORDS FIELDS I.S.OPRS) 
                                                             (LIST 'USE 'AS TYPE))
                                                        (RETURN NIL)))
                                          (COND
                                             (REL (SETQ REL (LIST TEM 'OR REL)))
                                             (T (SETQ REL TEM] FINALLY (RETURN REL)))

                       (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known")

                       'MASTERSCOPE)
                      ((EQMEMB 'EDITCALLERS METHOD)
                       'EDITCALLERS)
                      (T 'SEARCH))
              (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND
                                                     ((NULL FILES)
                                                      (UPDATEFILES)
                                                      (FILEPKGCHANGES 'FNS]
                                                  (for FILE inside (OR FILES FILELST)
                                                     join (FILEFNSLST FILE]
                                 (FUNCTION UPDATEFN))
                           (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL))
                                                          T)
                                            FNS)))
              (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST)
                                          when (SETQ TEM (EDITCALLERS OLD X T))
                                          collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM)))
                                                             X))))
              (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST
                                                                                   X))))
              (ERROR "UNRECOGNIZED RENAME METHOD" METHOD))
          (AND (EQMEMB 'FNS AS-TYPES)
               (FMEMB OLD FNS)
               (SETQ FNS (REMOVE OLD FNS)))
          (EDITFROMFILE FNS FILES OLD EDITCOMS)
          [for TYPE inside AS-TYPES
             do (for FILE in (WHEREIS OLD TYPE FILES)
                       do (AND (ADDTOFILE NEW TYPE FILE)
                                   (DELFROMFILES OLD TYPE FILE)
                                   (printout T OLD " changed to " NEW " on " FILE)))
                   (COND
                      ((SETQ TEM (WHEREIS OLD TYPE FILES))
                       (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM]
          (COND
             (REL (UPDATECHANGED)
                  (COND
                     ((AND (SETQ TEM (GETRELATION OLD REL T))
                           (WHEREIS TEM 'FNS FILES))
                      (printout T "Couldn't find where " OLD " is referenced in " TEM T])
)
(DEFINEQ

(SHOWDEF
  [LAMBDA (NAME TYPE FILE)                              (* ; "Edited 16-Apr-2018 21:35 by rmk:")
                                                             (* ; 
                                                 "prettyprint NAME as it would be dumped as a TYPE")
    (RESETLST
        (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
              (DECLARE (SPECVARS . T))
              [AND FILE (NEQ FILE (OUTPUT))
                   (if (SETQ FL (OPENP FILE 'OUTPUT))
                       then (RESETSAVE (OUTPUT FL))
                     else (OUTFILE FILE)
                           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                                (OUTPUT]
              (PRETTYCOM (MAKENEWCOM NAME TYPE))))])

(COPYDEF
  [LAMBDA (OLD NEW TYPE SOURCE OPTIONS)              (* lmm "14-Aug-84 18:38")
                                                             (* ; "like MOVD, but takes a type.")
    (PROG (TEM DEF)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          [SETQ DEF (GETDEF OLD TYPE SOURCE (COND
                                                   ((EQ OPTIONS 'NOCOPY)
                                                    NIL)
                                                   (T (REMOVE 'NOCOPY (MKLIST OPTIONS]
                                                             (* ; 
      "The default is for GETDEF to return a COPY.  Make sure that NOCOPY isn't in options though.")
          (SELECTQ TYPE
              (VARS)
              (FILES [for X in (CAR DEF)
                        do                               (* ; 
                                          "change all the listnames which are of form filenameTYPE")
                              (SELECTQ (CAR X)
                                  ((PROP IFPROP) 
                                       (SETQ X (CDR X)))
                                  NIL)
                              (COND
                                 ((EQ (CADR X)
                                      '*)
                                  (SETQ X (CDDR X))
                                  (COND
                                     ((AND (LITATOM (CAR X))
                                           (SETQ TEM (STRPOS OLD (CAR X)
                                                            1 NIL T T)))
                                      (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X)
                                                                           TEM -1)))
                                             (COPY (GETTOPVAL (CAR X)))
                                             T)
                                      (FRPLACA X TEM])
              ((PROPS ALISTS) 
                   (OR (EQ (CAR NEW)
                           (CAR OLD))
                       (DSUBST (CAR NEW)
                              (CAR OLD)
                              DEF))
                   (OR (EQ (CADR NEW)
                           (CADR OLD))
                       (DSUBST (CADR NEW)
                              (CADR OLD)
                              DEF)))
              (DSUBST NEW OLD DEF))
          (PUTDEF NEW TYPE DEF)
          (RETURN NEW])

(GETDEF
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "13-Jul-85 04:10")

    (* ;; "returns the definition of NAME as a TYPE from SOURCE;  cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found.  The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.")

    (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS)))
          (DECLARE (SPECVARS NOCOPY))
          (SELECTQ OPTIONS
              (0 (SETQQ OPTIONS (NOERROR NODWIM))
                 (SETQ NOCOPY T))
              (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST))
                 (SETQ NOCOPY T))
              (T (SETQQ OPTIONS SPELL))
              NIL)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          (SELECTQ SOURCE
              (0 (SETQQ SOURCE CURRENT))
              (T (SETQQ SOURCE SAVED))
              (NIL (SETQQ SOURCE ?))
              NIL)
          [SELECTQ SOURCE
              (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS)))
              (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS]
                      (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS])
              (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS)))
              (COND
                 ((AND (LISTP SOURCE)
                       (EQ (CAR SOURCE)
                           '=))
                  (SETQ DEF (CDR SOURCE)))
                 (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS))
                    (SETQ NOCOPY T]
          (OR NOCOPY (SETQ DEF (COPY DEF)))
          (COND
             ((AND (EQ TYPE 'FNS)
                   (NOT (EQMEMB 'NODWIM OPTIONS)))
              (DWIMDEF DEF NAME SOURCE)))
          (RETURN DEF])

(GETDEFCOM
  [LAMBDA (X)                                            (* lmm " 4-Jul-85 13:31")

    (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in.  Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed.  --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.  That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.")
                                                             (* ; "a RETFROM point")
    (for Y in X join (GETDEFCOM0 Y])

(GETDEFCOM0
  [LAMBDA (COM)                                          (* wt%: " 7-FEB-79 23:28")
    (PROG (TEM)
          (RETURN (COND
                     ((SETQ TEM (fetch MACRO of (CAR COM)))
                                                             (* COND ((fetch CONTENTS of
                                                           (CAR COM)) (* ; 
                        "if it has a CONTENTS function, generally means it is not safe to evaluate")
                                                           (RETFROM (QUOTE GETDEFCOM))))
                      (for Y in (SUBPAIR (CAR TEM)
                                               (PRETTYCOM1 COM)
                                               (CDR TEM)) join (GETDEFCOM0 Y)))
                     (T (SELECTQ (CAR COM)
                            (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X)))
                            (ADDVARS (for Y in (PRETTYCOM1 COM)
                                        collect (CONS 'ADDTOVAR Y)))
                            (APPENDVARS (for Y in (PRETTYCOM1 COM)
                                           collect (CONS 'APPENDTOVAR Y)))
                            (P (APPEND (PRETTYCOM1 COM)))
                            (RETFROM 'GETDEFCOM])

(GETDEFCURRENT
  [LAMBDA (NAME TYPE OPTIONS)                            (* ; "Edited  2-May-87 19:00 by Pavel")
                                                             (* ; 
                                                           "Gets the current definition--source=0")
    (LET
     (DEF)
     (COND
        ((AND (SETQ DEF (fetch GETDEF of TYPE))
              (NEQ DEF T))

         (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")

         (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS))
                  (fetch NULLDEF of TYPE))
             (GETDEFERR NAME TYPE OPTIONS))
         DEF)
        (T
         (OR
          (NEQ
           [SETQ DEF
            (SELECTQ TYPE
                (FNS (AND (LITATOM NAME)
                          (EXPRP (SETQ DEF (VIRGINFN NAME)))
                          DEF))
                (VARS (if (LITATOM NAME)
                          then (GETTOPVAL NAME)
                        else 'NOBIND))
                ((FIELDS RECORDS) 
                     (if (LITATOM NAME)
                         then [SETQ DEF (SELECTQ TYPE
                                                (RECORDS (RECLOOK NAME))
                                                (MKPROGN (FIELDLOOK NAME]
                               (if (EQMEMB 'EDIT OPTIONS)
                                   then (COPY DEF)
                                 else DEF)))
                (FILES                                       (* ; 
              "what is the `definition' of a file?  -- I guess the COMS which say what it contains")
                       [if (LITATOM NAME)
                           then (if (SETQ DEF (GETFILEDEF NAME))
                                        then (UPDATEFILES)
                                              (LIST (LISTP (GETTOPVAL (FILECOMS DEF)))
                                                    (fetch TOBEDUMPED
                                                       of (fetch FILEPROP of DEF))
                                                    (LISTP (fetch FILEDATES of DEF])
                (TEMPLATES (if (AND (LITATOM NAME)
                                        (SETQ DEF (GETTEMPLATE NAME)))
                               then (LIST 'SETTEMPLATE (KWOTE NAME)
                                              (KWOTE DEF))))
                (MACROS [if [AND (LITATOM NAME)
                                     (SETQ DEF (for X on (GETPROPLIST NAME)
                                                  by (CDDR X) when (FMEMB (CAR X)
                                                                                  MACROPROPS)
                                                  join (LIST (CAR X)
                                                                 (CADR X]
                            then `(PUTPROPS ,NAME ,@DEF])
                (EXPRESSIONS (LISTP NAME))
                (PROPS [AND (LISTP NAME)
                            (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME))
                                                 [FUNCTION (LAMBDA (X)
                                                             (EQ X (CADR NAME]
                                                 (FUNCTION CDDR)))
                                 (LIST 'PUTPROPS (CAR NAME)
                                       (CADR NAME)
                                       (CADR DEF])
                (FILEPKGCOMS [AND (LITATOM NAME)
                                  (PROG ((COM (FILEPKGCOM NAME))
                                         (TYP (FILEPKGTYPE NAME)))
                                        (RETURN (COND
                                                   ((AND COM TYP)
                                                    (LIST (CONS 'COM COM)
                                                          (CONS 'TYPE TYP)))
                                                   (COM (LIST (CONS 'COM COM)))
                                                   (TYP (LIST (CONS 'TYPE TYP])
                (FILEVARS (COND
                             ((AND (LITATOM NAME)
                                   (LISTP (SETQ DEF (GETTOPVAL NAME)))
                                   (WHEREIS NAME 'FILEVARS))
                              DEF)
                             (T 'NOBIND)))
                (LET
                 ((COMS (LIST (MAKENEWCOM NAME TYPE)))
                  FILE)
                 [COND
                    ((NOT (SETQ DEF (GETDEFCOM COMS)))
                     (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
                         (RESETLST
                             (RESETSAVE PRETTYFLG)
                             (RESETSAVE FONTCHANGEFLG)
                             [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
                             (PRETTYDEFCOMS COMS)
                             (SETFILEPTR FILE 0)
                             [SETQ DEF
                              (for X in (READFILE FILE)
                                 join
                                 (SELECTQ (CAR X)
                                     ((*) 
                                          NIL)
                                     (DECLARE%: (for Y on (CDR X)
                                                   unless (SELECTQ (CAR Y)
                                                                  ((COPYWHEN EVAL@LOADWHEN 
                                                                          EVAL@COMPILEWHEN) 
                                                                       (RETURN (LIST Y)))
                                                                  (FMEMB (CAR Y)
                                                                         DECLARETAGSLST))
                                                   collect (CAR Y)))
                                     (CL:EVAL-WHEN (CDDR X))
                                     (PROGN (CDR X))
                                     (LIST X]
                             (SETQ NOCOPY T)))]
                 (MKPROGN DEF]
           (fetch NULLDEF of TYPE))
          (GETDEFERR NAME TYPE OPTIONS))
         DEF])

(GETDEFERR
  [LAMBDA (NAME TYPE OPTIONS MSG)                        (* lmm "13-Jul-85 04:11")
    (DECLARE (USEDFREE NODEF))                           (* ; 
                                       "Message non-null if looking for saved or filed definition.")
    (PROG (TEM)
          (RETURN (COND
                     ((EQMEMB 'NOERROR OPTIONS)              (* ; 
                                               "We want to do the string search in the HASDEF case")
                      (RETURN (fetch NULLDEF of TYPE)))
                     [(AND (NULL MSG)
                           (EQMEMB 'SPELL OPTIONS)
                           (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS)
                                                                          'SPELL)
                                                                   T)))
                           (NEQ TEM NAME))
                      (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS]
                     (T (for O inside OPTIONS when (STRINGP O)
                           do (RETFROM 'GETDEF O)
                           finally (ERROR NAME (CONS TYPE '(definition not found))
                                              T])

(GETDEFFROMFILE
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: " 1-Oct-86 22:10")

    (* ;; "Tries to get definition from source file.  If successful, returns the definition.  Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.")

    (DECLARE (SPECVARS NAME))
    (bind (NOTFOUND _ "not found")
           DEF SOURCE TEM2 for FILE inside (COND
                                                      ((EQ SOURCE 'FILE)
                                                       (WHEREIS NAME TYPE T))
                                                      (T SOURCE))
       when
       (AND
        (SETQ SOURCE (FINDFILE FILE T))
        (NEQ
         [SETQ DEF
          (COND
             ((SETQ TEM2 (fetch FILEGETDEF of TYPE))
              (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND))
             (T
              (SELECTQ TYPE
                  (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  ((VARS FILEVARS) 
                       (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (COND
                     [(SETQ DEF (GET TYPE 'DEFINERS))
                      (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF
                                        `(LAMBDA (FIRST SECOND)
                                           (AND (MEMB FIRST ',DEF)
                                                (OR (EQ SECOND NAME)
                                                    (AND (MEMB SECOND '(%( %[))
                                                         (PROGN (RATOM)
                                                                (RATOM)
                                                                (RATOM)
                                                                (EQ NAME (RATOM]
                                                             (* ; "ick!  Should use real closure")
                           (if (EQ (CAAR VAL)
                                       'NOT-FOUND)
                               then NOTFOUND
                             elseif (CDR VAL)
                               then (CONS 'PROGN VAL)
                             else (CAR VAL]
                     (T (RESETLST
                            (RESETSAVE (RESETUNDO))
                            [LET (LOAD-VERBOSE-STREAM)
                                 (DECLARE (SPECVARS LOAD-VERBOSE-STREAM))
                                                             (* ; 
                                                     "just in case we get a PRETTYCOMPRINT in here")
                                 (LOADFNS NIL SOURCE 'PROP (COND
                                                              ((LITATOM NAME)
                                                             (* ; 
                                         "If an atom, only bother with expressions that contain it")
                                                               (CONS (LIST '& '|..| NAME)))
                                                              (T T]
                            (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))]
         NOTFOUND)) do (AND (EQ SOURCE 'FILE)
                                (OR (FMEMB FILE FILELST)
                                    (CL:FORMAT T "(from ~A)~%%" SOURCE))) 
                                                             (* ; 
                                                        "Copying and dwimifying are done in GETDEF")
                          (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
                                                                  (APPEND '(no definition on)
                                                                         (MKLIST SOURCE])

(GETDEFSAVED
  [LAMBDA (NAME TYPE OPTIONS)                          (* ; "Edited 11-Aug-87 18:14 by cutting")
                                                             (* ; 
                                                           "Gets the `saved' definition--source=T")
    (SELECTQ TYPE
        (FNS (OR (GETPROP NAME 'EXPR)
                 (GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
        (VARS                                                (* ; 
                               "The value of a variable is never substituted into and never COPIED")
              (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
                                                                                'VALUE)
                 do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS 
                                                                     "no saved value for "))))
        (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS)))
            (GETDEFERR NAME TYPE OPTIONS "no saved definition for "])

(PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* ; "Edited  8-Apr-87 12:52 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE)))
         (COND
            (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON))
            (T (SELECTQ TYPE
                   (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON))
                   (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON))
                   (EVAL DEFINITION))
               NAME])

(EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)
    (DECLARE (LOCALVARS . T)
           (SPECVARS SOURCE))                          (* ; "Edited 27-Jul-87 11:04 by cutting")

    (* ;; "lets you edit anything.  Given name and type, call editor on the definition (loading it in from SOURCE if necessary).  If you change it, then the definition gets unsaved.  OPTIONS is passed through from ED to the editor.")

    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (COND
       ((AND (fetch EDITDEF of TYPE)
             (APPLY* (fetch EDITDEF of TYPE)
                    NAME TYPE SOURCE EDITCOMS OPTIONS)))
       ((AND (EQ TYPE 'FNS)
             (NULL SOURCE))                                  (* ; 
                                "special hack for EDITDEF of FNS because of ability to EDITLOADFNS")
        (EDITDEF.FNS NAME EDITCOMS OPTIONS))
       (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))
    NAME])

(DEFAULT.EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 11-Jun-92 16:26 by cat")
    (PROG [(DEF (COND
                   [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
                   [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
                   [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
                   (T (LET ((FILES (WHEREIS NAME TYPE T)))
                           (CL:IF (NULL FILES)
                               (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE)
                               [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME 
                                                         FILES)
                                                  (CL:IF (CL:ENDP (CDR FILES))
                                                      (CL:IF (CL:Y-OR-N-P 
                                                                    "Shall I load this file PROP? ")
                                                             (CAR FILES))
                                                      (ASKUSER NIL NIL 
                                                             "indicate which file to load PROP: "
                                                             (MAKEKEYLST FILES)
                                                             T))]
                                    (CL:WHEN FILE
                                        (LOAD FILE 'PROP)
                                        (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])]

     (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")

          (DECLARE (SPECVARS RETRY))

     (* ;; "what is RETRY ???")

          (SETQ RETRY)
          (CL:WHEN DEF
              (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
                                                             (* ; 
                                             "this function is called when there were changes made")
                                                        (FIXEDITDATE DEF)
                                                             (* ; "fix the edit date first - jtm")
                                                        (PUTDEF NAME TYPE DEF)
                                                        (MARKASCHANGED NAME TYPE 'CHANGED)

                                 (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition.  doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here.  this sometimes results in MARKASCHANGED getting called twice.")

                                                        ]
                     OPTIONS))])

(EDITDEF.FILES
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 18-Mar-87 16:07 by woz")
    (EDITDEF (FILECOMS NAME)
           'VARS SOURCE EDITCOMS OPTIONS])

(LOADDEF
  [LAMBDA (NAME TYPE SOURCE)                             (* lmm "13-SEP-78 01:34")
    (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY])

(DWIMDEF
  [LAMBDA (DEF FN SOURCE)                                (* lmm " 6-Jun-86 17:23")
    (AND [OR (EQ DWIMIFYCOMPFLG T)
             (EQ CLISPIFYPRETTYFLG T)
             (EQ (CAR (CADDR DEF))
                 'CLISP%:)
             (SELECTQ SOURCE
                 ((CURRENT SAVED FILE ?) 
                      NIL)
                 (AND (LITATOM SOURCE)
                      (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE]
         (LET ((NOSPELLFLG T)
               (DWIMESSGAG T)
               FILEPKGFLG LISPXHIST)
              (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST))
              (DWIMIFY0 DEF (COND
                               ((OR (LISTP FN)
                                    (NULL FN))
                                '?)
                               (T FN))
                     NIL DEF])

(DELDEF
  [LAMBDA (NAME TYPE)                                    (* ; "Edited  5-Dec-86 06:20 by lmm")
    (PROG (TEM)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
      LP  [COND
             ((SETQ TEM (fetch DELDEF of TYPE))
              (APPLY* TEM NAME TYPE))
             (T (SELECTQ TYPE
                    (FNS                                     (* ; 
  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such")
                         (AND (EXPRP NAME)
                              (/PUTD NAME))
                         (REMPROP NAME 'EXPR)
                         [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME])
                    (VARS (/SETTOPVAL NAME 'NOBIND))
                    (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES)
                              do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST]
                           (/replace FILEPROP of NAME with NIL)
                           (/replace FILECHANGES of NAME with NIL)
                           (/replace FILEDATES of NAME with NIL)
                           (FLUSHFILEMAPS NAME))
                    (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME)
                                 (DELFROMLIST 'FILEPKGTYPES NAME)
                                 (for FIELD on (FILEPKGCOM NAME)
                                    by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD)
                                                                      NIL))
                                 (for FIELD on (FILEPKGTYPE NAME)
                                    by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD)
                                                                      NIL))
                                 (/replace ALLFIELDS of NAME with NIL))
                    (ALISTS [AND (LISTP NAME)
                                 (DELFROMLIST (CAR NAME)
                                        (FASSOC (CADR NAME)
                                               (GETTOPVAL (CAR NAME])
                    (MACROS (for P in MACROPROPS do (/REMPROP NAME P)))
                    (PROPS (AND (LISTP NAME)
                                (/REMPROP (CAR NAME)
                                       (CADR NAME))))
                    (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS))
                                 (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS
                                                                             ))
                                 (DELFROMLIST 'LISPXCOMS NAME)
                                 (DELFROMLIST 'HISTORYCOMS NAME))
                    (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet")
                           T]
          (MARKASCHANGED NAME TYPE 'DELETED)
          (RETURN NAME])

(DELFROMLIST
  [LAMBDA (VAR VAL)                                      (* rmk%: " 3-JAN-82 23:22")
    (AND (FMEMB VAL (GETTOPVAL VAR))
         (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR)
                                (FUNCTION (LAMBDA (X)
                                            (AND (NEQ X VAL)
                                                 (OR (NLISTP X)
                                                     (NEQ (CDR X)
                                                          VAL])

(HASDEF
  [LAMBDA (NAME TYPE SOURCE SPELLFLG)                    (* ; "Edited 31-Aug-87 18:02 by drc:")

    (* ;; "is NAME the name of something of type TYPE?  NIL SOURCE means 0, not ?")

    (DECLARE (SPECVARS TYPE))
    (COND
       [[OR (LISTP TYPE)
            (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG")
        (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
                                            (RETURN $$VAL]
       (T
        (PROG [(NODEF (fetch NULLDEF of TYPE))
               (OPTS '(NODWIM NOCOPY NOERROR HASDEF]
              (COND
                 ((NULL SOURCE)
                  (SETQQ SOURCE CURRENT)))
              (RETURN
               (SELECTQ SOURCE
                   ((CURRENT 0) 
                        [COND
                           ([OR
                             (MEMBER NAME (fetch CHANGED of TYPE))
                             (LET ((TM (fetch HASDEF of TYPE)))
                                  (COND
                                     (TM (APPLY* TM NAME TYPE SOURCE))
                                     [(NOT (LITATOM NAME))
                                      (SELECTQ TYPE
                                          (PROPS (AND (LISTP NAME)
                                                      (GETPROP (CAR NAME)
                                                             (CADR NAME))))
                                          ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS 
                                                  FIELDS USERMACROS FILEVARS FILEPKGCOMS) 
                                               NIL)
                                          (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                                     (T 
                                        (* ;; "symbol definitions")

                                        (SELECTQ TYPE
                                            (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS")
                                                                        "INTERLISP")))
                                                        (AND SYMBOL (BOUNDP SYMBOL))))
                                            (TEMPLATES (GETTEMPLATE NAME))
                                            (MACROS (GETLIS NAME MACROPROPS))
                                            (LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
                                                             (FASSOC NAME LISPXHISTORYMACROS)))
                                            (VARS (AND (NOT (CL:KEYWORDP NAME))
                                                       (NEQ (GETTOPVAL NAME)
                                                            'NOBIND)))
                                            (RECORDS (RECLOOK NAME))
                                            (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD]
                                                            (RETURN (AND TEM (EQ (CAR TEM)
                                                                                 'FORWORD)
                                                                         (GETPROP (CDR TEM)
                                                                                'I.S.OPR])
                                            (FNS (AND (OR (AND (GETD NAME)
                                                               (EXPRP (GETD NAME)))
                                                          (GET NAME 'EXPR))
                                                      (NOT (HASDEF NAME 'FUNCTIONS SOURCE))))
                                            (FIELDS (RECORDFIELD? NAME))
                                            (USERMACROS (FASSOC NAME USERMACROS))
                                            (FILEVARS)
                                            ((PROPS ALISTS DEFS EXPRESSIONS) 
                                                 NIL)
                                            (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
                                                             (FMEMB NAME FILEPKGTYPES)))
                                            (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                            (OR NAME T))
                           (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME)
                                         (FIXSPELL NAME NIL
                                                (SELECTQ TYPE
                                                    (FILES FILELST)
                                                    (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES))
                                                    (FIELDS (for X in USERRECLST
                                                               join (APPEND (RECORDFIELDNAMES
                                                                                 X))))
                                                    (RECORDS (for X in USERRECLST
                                                                when (LITATOM (CADR X))
                                                                collect (CADR X)))
                                                    (LISPXMACROS LISPXCOMS)
                                                    (I.S.OPRS I.S.OPRLST)
                                                    (USERMACROS (MAPCAR USERMACROS
                                                                       (FUNCTION CAR)))
                                                    USERWORDS)
                                                NIL
                                                (LISTP SPELLFLG)
                                                [FUNCTION (LAMBDA (X)
                                                            (HASDEF X TYPE 'CURRENT]
                                                NIL T))])
                   (? (OR (HASDEF NAME TYPE 'CURRENT)
                          (AND (LITATOM NAME)
                               (HASDEF NAME TYPE 'SAVED SPELLFLG))
                          (WHEREIS NAME TYPE T)))
                   ((SAVED T) 
                        (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS)))
                   (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])

(GETFILEDEF
  [LAMBDA (FILENAME)                                     (* lmm " 4-Jul-85 13:25")

    (* ;; 
  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST")

    (COND
       ((FMEMB FILENAME FILELST)
        FILENAME)
       (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T)
             do (COND
                       ((EQ (FILENAMEFIELD FILE 'NAME)
                            FILENAME)
                        (RETURN FILE])

(SAVEDEF
  [LAMBDA (NAME TYPE DEFINITION)                         (* JonL "24-Jul-84 20:11")
    (COND
       [(AND (LISTP NAME)
             (NULL TYPE))
        (MAPCAR NAME (FUNCTION (LAMBDA (I)
                                 (SAVEDEF I 'FNS]
       (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME)))
                        (/PUT NAME [SETQ TYPE (COND
                                                 ((SUBRP DEFINITION)
                                                  'SUBR)
                                                 ((EXPRP DEFINITION)
                                                  'EXPR)
                                                 ((CCODEP DEFINITION)
                                                  'CODE)
                                                 (T 'LIST]
                              DEFINITION)))
              (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME)))
                              'NOBIND)
                         (EQ DEFINITION (GETTOPVAL NAME))
                         (/PUT NAME (SETQ TYPE 'VALUE)
                               DEFINITION)))
              (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT
                                                          '(NOCOPY NOERROR NODWIM]
                   (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS))
                                                  (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME))
                                                                             SAVEDDEFS]
          TYPE])

(UNSAVEDEF
  [LAMBDA (NAME TYPE DEF)                                (* lmm " 6-Jun-86 17:24")
    (SELECTQ TYPE
        ((NIL EXPR CODE SUBR LIST) 
             (COND
                [(LISTP NAME)                                (* ; "for compatibility")
                 (MAPCAR NAME (FUNCTION (LAMBDA (X)
                                          (UNSAVED1 X TYPE]
                (T (UNSAVED1 NAME TYPE))))
        (PROG NIL
              [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
                                       'SAVED 0))
                  (RETURN (CONS TYPE '(not found]
              (COND
                 ((NEQ DFNFLG T)
                  (SAVEDEF NAME TYPE)
                  (LET ((DFNFLG T))
                       (PUTDEF NAME TYPE DEF)))
                 (T (PUTDEF NAME TYPE DEF)))
              (RETURN TYPE])

(COMPAREDEFS
  [LAMBDA (NAME TYPE SOURCES)                            (* lmm " 4-Jul-85 14:37")
    (COND
       ((AND (LISTP TYPE)
             (GETFILEPKGTYPE SOURCES NIL T))
        (swap TYPE SOURCES)))
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T]
          [COND
             ((NULL SOURCES)
              (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE))
                       (SOME SRCS (FUNCTION (LAMBDA (FILE)
                                              (MEMBER NAME (CDR (ASSOC TYPE
                                                                       (fetch TOBEDUMPED
                                                                          of (fetch FILEPROP
                                                                                    of FILE]
                   (push SRCS 'CURRENT]
          (SETQ SRCS (for SRC in SRCS
                        when (COND
                                    ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
                                          (fetch NULLDEF of TYPE))
                                     (OR [SOME DEFS (FUNCTION (LAMBDA (DP)
                                                                (COMPARELST DEF (CDR DP]
                                         (push DEFS (CONS SRC DEF)))
                                     T)
                                    (T (PRINTOUT T "No " SRC " definition found for " NAME T)
                                       NIL)) collect SRC))
          (RETURN (COND
                     ((NULL SRCS)
                      '(no definitions found))
                     ((NULL (CDR SRCS))
                      '(only one definition found))
                     ((CDR DEFS)
                      [for S1 on (DREVERSE DEFS)
                         do (for S2 on (CDR S1) do (PRIN2 NAME T T)
                                                                  (AND (CAAR S1)
                                                                       (PRIN1 " from " T)
                                                                       (PRIN2 (CAAR S1)
                                                                              T T))
                                                                  (PRIN1 " and " T)
                                                                  (PRIN2 NAME T T)
                                                                  (COND
                                                                     ((CAAR S2)
                                                                      (PRIN1 " from " T)
                                                                      (PRIN2 (CAAR S2)
                                                                             T T)))
                                                                  (PRIN1 " differ:" T)
                                                                  (TERPRI T)
                                                                  (COMPARELISTS (CDAR S1)
                                                                         (CDAR S2]
                      'DIFFERENT)
                     (T 'SAME])

(COMPARE
  [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2)             (* lmm " 5-SEP-78 13:37")
    (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY]
           (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY]
          (COND
             ((COMPARELST DEF1 DEF2)
              (RETURN)))
          (PRIN2 NAME1 T T)
          (COND
             (SOURCE1 (PRIN1 " from " T)
                    (PRIN2 SOURCE1 T T)))
          (PRIN1 " and " T)
          (PRIN2 NAME2 T T)
          (COND
             (SOURCE2 (PRIN1 " from " T)
                    (PRIN2 SOURCE2 T T)))
          (PRIN1 " differ:" T)
          (TERPRI T)
          (COMPARELISTS DEF1 DEF2)
          (RETURN T])

(TYPESOF
  [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER)
                                                          (* ; "Edited  2-Aug-88 02:08 by masinter")

    (* ;; "return list of all known types which NAME names")

    (LET
     (FOUND SHADOWED)
     (if (FMEMB SOURCE '(? NIL))
         then (CL:FLET [(RSHADOW NIL (for X in FOUND
                                            do (for Y in (CDR (FASSOC X SHADOW-TYPES))
                                                      do (if (FMEMB Y FOUND)
                                                                 then 
                                                             (* ; "shadower found before shadowed")
                                                                       (SETQ FOUND (REMOVE Y FOUND]
                         (LET (NOTFOUND NEWTYPES)
                              (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                                 when [AND (LITATOM TYPE)
                                               (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                               (OR (NULL FILTER)
                                                   (CL:FUNCALL FILTER TYPE))
                                               (NOT (find X in FOUND
                                                       suchthat (FMEMB TYPE
                                                                           (CDR (FASSOC X 
                                                                                       SHADOW-TYPES]
                                 do (if [OR (HASDEF NAME TYPE 'CURRENT)
                                                    (AND (LITATOM NAME)
                                                         (HASDEF NAME TYPE 'SAVED]
                                            then (push FOUND TYPE)
                                          else (push NOTFOUND TYPE)))
                              (RSHADOW)
                              [for FILE in FILELST while NOTFOUND
                                 when [NEQ T (fetch LOADTYPE of (GETPROP FILE
                                                                                   'FILE]
                                 do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND
                                                                      (FILECOMS FILE)
                                                                      'TYPESOF))
                                            then [bind X for TYPE in NEWTYPES
                                                        when (FMEMB TYPE NOTFOUND)
                                                        do (push FOUND TYPE)
                                                              (if (SETQ X (FASSOC TYPE 
                                                                                     SHADOW-TYPES))
                                                                  then (SETQ NOTFOUND
                                                                            (LDIFFERENCE NOTFOUND X))
                                                                else (SETQ NOTFOUND
                                                                          (REMOVE TYPE NOTFOUND]
                                                  (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES]
                              (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF))
                                  then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND))
                                        (SETQ FOUND (UNION NEWTYPES FOUND)))
                              (RSHADOW)
                              FOUND))
       else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                   when (AND (LITATOM TYPE)
                                 (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                 (OR (NULL FILTER)
                                     (CL:FUNCALL FILTER TYPE))
                                 (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE)))
     FOUND])
)

(RPAQ? WHEREIS.HASH )



(* ; "Must come after PUTDEF")

(DEFINEQ

(FIXEDITDATE
  [LAMBDA (EXPR)                                         (* ; "Edited 17-Jul-89 11:13 by jtm:")
                                                             (* NOBIND "18-JUL-78 21:11")
                                                             (* Inserts or replaces previous edit 
                                                           date)
    (AND INITIALS (LISTP EXPR)
         (LISTP (CDR EXPR))
         (PROG (E)
               (COND
                  ((FMEMB (CAR EXPR)
                          LAMBDASPLST)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR)))
                  [(FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-ARGLIST-DEFINERS)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR))
                   (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
                      finally (SETQ E (CDR E]
                  ((FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-NAME-DEFINERS)

                   (* ;; "insert the edit date after the name")

                   (SETQ E (CDDR EXPR)))
                  (T (RETURN)))
           RETRY
               [COND
                  ((NLISTP E)
                   (RETURN))
                  ((LISTP (CAR E))
                   (SELECTQ (CAAR E)
                       ((CLISP%: DECLARE) 
                            (SETQ E (CDR E))
                            (GO RETRY))
                       (BREAK1 (COND
                                  ((EQ (CAR (CADAR E))
                                       'PROGN)
                                   (SETQ E (CDR (CADAR E)))
                                   (GO RETRY))))
                       (ADV-PROG                             (* No easy way to mark cleanly the 
                                                           date of an advised function)
                                 (RETURN))
                       (COND
                          ((AND (EQ (CAAR E)
                                    COMMENTFLG)
                                (EQ (CADAR E)
                                    'DECLARATIONS%:))
                           (SETQ E (CDR E))
                           (GO RETRY]
               (COND
                  ([for TAIL on E while (AND (LISTP (CAR TAIL))
                                                         (EQ (CAAR TAIL)
                                                             COMMENTFLG))
                      do (COND
                                ((AND (LISTP (CDR TAIL))
                                      (EDITDATE? (CAR TAIL)))
                                 (/RPLACA TAIL (EDITDATE (CAR TAIL)
                                                      INITIALS))
                                 (RETURN T]                  (* scans the comments for a 
                                                           timestamp for this user.)
                   NIL)
                  (T                                         (* attach the new timestamp at the 
                                                           beginning of the comments.)
                     (/ATTACH (EDITDATE NIL INITIALS)
                            E)))
               (RETURN EXPR])

(EDITDATE?
  [LAMBDA (COMMENT)                                      (* ; "Edited 11-Jun-92 16:44 by cat")
                                                             (* ; "Edited 13-Jul-89 09:30 by jtm:")
                                                             (* lmm "21-Mar-85 08:45")

         (* Tests to see if a given common is in fact an edit date --
       this has to be general enough to recognize the most comment comment forms while 
       specific enough to not recognize things that are not edit dates)

    (DECLARE (LOCALVARS . T))                            (* jtm%: changed test so that it 
                                                           creates one timestamp per user.)
    (COND
       [(LISTP COMMENT)
        (COND
           ((EQ (CAR COMMENT)
                COMMENTFLG)
            [COND
               (NIL (NULL NORMALCOMMENTSFLG)
                    (SETQ COMMENT (GETCOMMENT COMMENT]
            (COND
               ([OR (NOT (LISTP (CDR COMMENT)))
                    (NOT (LISTP (CDDR COMMENT]
                NIL)
               [(EQ (CADR COMMENT)
                    ';)                                      (* ; "CL style comment")
                (STRPOS INITIALS (CADDR COMMENT)
                       (IMINUS (NCHARS INITIALS]
               (T                                            (* ; "IL style comment")
                  (EQ (CADR COMMENT)
                      INITIALS]
       ((STRINGP COMMENT])
)



(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")


(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))

(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
)



(* ;; 
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
)

(DEFINEQ

(FILEPKGCOM
  [LAMBDA N                                              (* JonL "10-Jul-84 19:38")
    (PROG (TEM (COM (ARG N 1)))
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in '(MACRO CONTENTS DELETE ADD)
                             when (SETQ TEM (FILEPKGCOM COM FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                               (LIST 'COM T))
                          (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                               (LIST 'COM TEM]
                     ((EQ N 2)
                      (SELECTQ (ARG N 2)
                          (ADD (fetch ADD of COM))
                          (DELETE (fetch DELETE of COM))
                          (MACRO (fetch MACRO of COM))
                          ((CONTENTS CONTAIN) 
                               [OR (fetch (FILEPKGCOM CONTENTS) of COM)
                                   (COND
                                      ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM))
                                       (COND
                                          ((EQ COM 'NILL)
                                           COM)
                                          [(EQ (CAR COM)
                                               'LAMBDA)
                                           (CONS (CAR COM)
                                                 (CONS [CONS (CAADR COM)
                                                             (CONS (OR (CADDR (CADR COM))
                                                                       'NAME)
                                                                   (CONS (CADR (CADR COM))
                                                                         (CDDDR (CADR COM]
                                                       (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM]
                                          (T (LIST 'LAMBDA '(COM TYPE NAME)
                                                   (CONS COM '(COM TYPE NAME])
                          (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                        T)
                                   (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST])
                          (ERROR (ARG N 2)
                                 "not file package command property")))
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'COM)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                (/SETTOPVAL 'FILEPKGCOMSPLST
                                                       (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST])
                                         (COND
                                            ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGCOMSPLST
                                                      (CONS (CONS COM TEM)
                                                            (GETTOPVAL 'FILEPKGCOMSPLST]
                                    (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                    (/SETTOPVAL 'FILEPKGCOMSPLST
                                                           (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                       (SELECTQ (ARG N I)
                                           (ADD (/replace (FILEPKGCOM ADD) of COM
                                                   with TEM))
                                           (DELETE (/replace (FILEPKGCOM DELETE) of
                                                                                         COM
                                                      with TEM))
                                           (MACRO (/replace (FILEPKGCOM MACRO) of COM
                                                     with TEM))
                                           ((CONTENTS CONTAIN) 
                                                (/replace (FILEPKGCOM CONTENTS) of COM
                                                   with TEM))
                                           (ERROR (ARG N I)
                                                  "not file package command property"]
                        (MARKASCHANGED COM 'FILEPKGCOMS])

(FILEPKGTYPE
  [LAMBDA N                                              (* lmm " 5-Jul-85 09:07")
    (PROG ((TYPE (ARG N 1))
           TEM)
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in (UNION '(DESCRIPTION)
                                                       FILEPKGTYPEPROPS)
                             when (SETQ TEM (FILEPKGTYPE TYPE FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                               (LIST 'TYPE T))
                          (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]
                               (LIST 'TYPE TEM]
                     [(EQ N 2)
                      (if (FMEMB (ARG N 2)
                                     FILEPKGTYPEPROPS)
                          then (GETPROP TYPE (ARG N 2))
                        else (SELECTQ (ARG N 2)
                                     (DESCRIPTION (fetch DESCRIPTION of TYPE))
                                     (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                                                    T)
                                               (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES])
                                     (ERROR (ARG N 2)
                                            "not file package type property"]
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'TYPE)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T (OR (FMEMB TYPE FILEPKGTYPES)
                                                (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES))))
                                         (COND
                                            ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES))
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM)
                                                                               FILEPKGTYPES]
                                    (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES)
                                                    (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES
                                                                                    ]
                                       (if (FMEMB (ARG N I)
                                                      FILEPKGTYPEPROPS)
                                           then (if TEM
                                                        then (/PUTPROP TYPE (ARG N I)
                                                                        TEM)
                                                      else (/REMPROP TYPE (ARG N I)))
                                         else (SELECTQ (ARG N I)
                                                      (DESCRIPTION (/replace DESCRIPTION
                                                                      of TYPE with TEM))
                                                      (ERROR (ARG N I)
                                                             "not file package command/type property"
                                                             ]
                        (MARKASCHANGED TYPE 'FILEPKGCOMS])
)

(PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS)))

(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)

(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE)
                                                                       (* Revert to NILL when no 
                                                                          longer coercing 
                                                                          PRETTYDEFMACROS to 
                                                                          FILEPKGCOMS)
                                                                       (AND (EQ TYPE 'FILEPKGCOMS)
                                                                            (INFILECOMTAIL COM]
                                                  (TYPE DESCRIPTION "file package commands/types" 
                                                        GETDEF T PUTDEF FILEPKGCOMS.PUTDEF)))
(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X]
                                             (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF 
                                                   WHENCHANGED (ALISTS.WHENCHANGED))))
(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X])
(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS)))
(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED (
                                                                              EXPRESSIONS.WHENCHANGED
                                                                                               )
                                                        EDITDEF NILL)))
(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL)))
(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)
                                                   (TYPE TYPE FILEPKGCOMS)))
(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X]
                                                 CONTENTS
                                                 (LAMBDA (COM NAME TYPE)
                                                        (AND (EQ TYPE 'FILES)
                                                             (SUBSET (INFILECOMTAIL COM)
                                                                    (FUNCTION LITATOM]
                                            (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED)
                                                  EDITDEF EDITDEF.FILES)))
(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X)))
                                               (TYPE NULLDEF NOBIND EDITDEF NILL)))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (FN)
                                                                         (AND (GETPROP FN
                                                                                     'FUNCTIONS)
                                                                              (CL:WARN 
                                                                      "~A has a FUNCTIONS definition"
                                                                                     FN]
                                                  (ORIGINAL (FNS . X)))
                                               CONTENTS NILL)
                                          (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF
                                                T)))
(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X)))
                                                       CONTENTS
                                                       (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                              (AND (NULL ONFILETYPE)
                                                                   (EQ TYPE 'RECORDS)
                                                                   (INFILECOMTAIL COM])
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS)))
(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X)))
                                                       CONTENTS NILL)
                                                  (TYPE DESCRIPTION "LISPX commands")))
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM
                                              MACRO
                                              [X
                                               (DECLARE%:
                                                EVAL@COMPILE
                                                (P
                                                 *
                                                 (MAPCAR
                                                  'X
                                                  (FUNCTION
                                                   (LAMBDA (Y)
                                                          (LET [[FNDEF (GETDEF Y 'FUNCTIONS
                                                                              'CURRENT
                                                                              '(NOCOPY NOERROR]
                                                                (MACDEF (GETDEF Y 'MACROS
                                                                               'CURRENT
                                                                               '(NOCOPY NOERROR]
                                                               (COND
                                                                ((AND FNDEF (EQ (CAR FNDEF)
                                                                                'DEFMACRO))
                                                                 (CL:WARN 
                           "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S."
                                                                        FNDEF)
                                                                 (LIST 'PROGN FNDEF MACDEF))
                                                                (T (OR MACDEF (CL:CERROR 
                                                          "Go ahead and finish writing out the file."
                                                                                     
                                                                       "No MACROS definition for ~A."
                                                                                     Y)
                                                                       (GETDEF Y 'MACROS 'CURRENT]
                                              CONTENTS NILL)
                                             (TYPE DESCRIPTION "Interlisp macros" GETDEF 
                                                   MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY))))
(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)))
(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X]
                                            (TYPE DESCRIPTION "property lists" WHENCHANGED (
                                                                                    PROPS.WHENCHANGED
                                                                                            ))))
(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM
                                               MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (RECORD)
                                                                         (AND (GETPROP RECORD
                                                                                     'STRUCTURES)
                                                                              (CL:WARN 
                                                                     "~A has a STRUCTURES definition"
                                                                                     RECORD]
                                                  (E (RECORDECLARATIONS . X))
                                                  (INITRECORDS . X))
                                               CONTENTS
                                               (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                      (AND (EQ TYPE 'FIELDS)
                                                           (NULL ONFILETYPE)
                                                           (MAPCONC (INFILECOMTAIL COM)
                                                                  (FUNCTION (LAMBDA
                                                                             (X)
                                                                             (APPEND (
                                                                                     RECORDFIELDNAMES
                                                                                      X]
                                              (TYPE DESCRIPTION "records" DELDEF
                                                    (LAMBDA (X)
                                                           (/SETTOPVAL 'USERRECLST
                                                                  (REMOVE (RECLOOK X)
                                                                         USERRECLST])
(PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X)))
                                                      CONTENTS
                                                      (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                             (AND (NULL ONFILETYPE)
                                                                  (EQ TYPE 'RECORDS)
                                                                  (INFILECOMTAIL COM])
(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X)))
                                                      CONTENTS NILL)
                                                 (TYPE DESCRIPTION "edit macros")))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                                (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                          (VAR)
                                                                          (AND (GETPROP VAR
                                                                                      'VARIABLES)
                                                                               (CL:WARN 
                                                                 "~A also has a VARIABLES definition"
                                                                                      VAR]
                                                   (ORIGINAL (VARS . X)))
                                                CONTENTS NILL)
                                           (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF 
                                                 VARS.PUTDEF)))
(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL)))
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X)
                                                                     (P (CONSTANTS . X])

(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
                           (VARIABLES VARS CONSTANTS))

(RPAQ? SAVEDDEFS )



(* ; "EDITCALLERS")

(DEFINEQ

(FINDCALLERS
  [LAMBDA (ATOMS FILES)                                  (* lmm "30-SEP-78 01:36")
    (PROG ((X (EDITCALLERS ATOMS FILES T)))
          (RETURN (NCONC (DREVERSE (CDR X))
                         (AND (CAR X)
                              (LIST (CONS (COND
                                             ((CDR X)
                                              '"plus other places on")
                                             (T 'on))
                                          (CAR X])

(EDITCALLERS
  [LAMBDA (ATOMS FILES COMS)                            (* ; "Edited  8-Aug-2020 17:32 by rmk:")
                                                             (* bvm%: " 3-Nov-86 17:30")
    (LET
     (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN)
     [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS]
     [for FILE in (COND
                             ((NULL FILES)
                              FILELST)
                             ((EQ FILES T)
                              (UNION SYSFILES FILELST))
                             ((LISTP FILES)
                              FILES)
                             (T (LIST FILES)))
        do
        (RESETLST
            [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I)
                  (OR (SETQ FULL (FINDFILE FILE))
                      (RETURN (LISPXPRINT (CONS FILE '(not found))
                                     T T)))
                  [RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                       (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT]
                  (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM)))
                  (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP)
                         (OR (GET-ENVIRONMENT-AND-FILEMAP FULL)
                             (\PARSE-FILE-HEADER FILESTREAM)))

             (* ;; "Get reader environment of file.  The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists.  Otherwise, read the top of the file")

                  (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV)))
                  (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL))
                  [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS)))
                      (push FFILEPOSPATTERNS
                             (CONS RDTBL (SETQ PATTERNS
                                          (for ATOM in ATOMS
                                             collect (CONCAT
                                                          (COND
                                                             ((EQ (CHCON1 ATOM)
                                                                  (CHARCODE ESCAPE))
                                                              (SETQ ATOM (SUBSTRING ATOM 2 -1))
                                                              "")
                                                             (T " "))
                                                          [COND
                                                             ((SETQ I (STRPOS ' ATOM))
                                                              (SUBSTRING ATOM 1 (SUB1 I)))
                                                             ((STRINGP ATOM))
                                                             (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE
                                                                                  ATOM)))
                                                             (* ; 
                                                           "Keep MKSTRING from putting a prefix on")
                                                                     (MKSTRING ATOM T RDTBL]
                                                          (COND
                                                             (I "")
                                                             (T " "]
                  (for PATTERN in PATTERNS
                     do
                     (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0)))
                     (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA))
                        do
                        (COND
                           ((NULL PRINTFLG)                  (* ; 
                                   "cause the printing of the filename to be saved on history list")
                            (SETQ PRINTFLG T)
                            (LISPXPRIN2 FULL T T T)

                            (* ;; "print with NODOFLG=T means just to record the printing;  the idea is that only those files in which something is found will be remembered on the history list")

                            (LISPXPRIN1 ": " T NIL T)))
                        [OR
                         [AND (NEQ MAP T)
                              (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0)
                                                                    (SETQ MAP (OR (GETFILEMAP 
                                                                                         FILESTREAM)
                                                                                  (LOADFILEMAP 
                                                                                         FILESTREAM]
                                                         (PROGN 
                                                             (* ; "file has no filemap")
                                                                (SETQ MAP (SETQ NOMAPFLG T))
                                                                (LISPXPRIN1 " no filemap!" T)
                                                                NIL)))
                                 thereis (AND (ILESSP (CAR X)
                                                         I)
                                                  (IGREATERP (CADR X)
                                                         I)
                                                  (for Z in (CDDR X)
                                                     thereis (COND
                                                                    ((AND (ILESSP (CADR Z)
                                                                                 I)
                                                                          (IGREATERP (CDDR Z)
                                                                                 I))
                                                                     [COND
                                                                        ((NOT (FMEMB (CAR Z)
                                                                                     FNS))
                                                                         (SETQ FNS
                                                                          (CONS (LISPXPRIN2
                                                                                 (CAR Z)
                                                                                 T T)
                                                                                FNS]
                                                                     (SETQ I (CDDR Z))
                                                                     T]
                         (PROGN (LISPXPRIN2 I T T)
                                (OR (FMEMB FILE OTHERSFILES)
                                    (SETQ OTHERSFILES (CONS FILE OTHERSFILES]
                        (LISPXSPACES 1 T)))
                  (COND
                     (PRINTFLG (LISPXTERPRI T))
                     (T (TERPRI T)))
                  (COND
                     ((NEQ COMS T)
                      (COND
                         ((OR FNS OTHERSFILES)
                          (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS))
                                 FULL EDITPATTERN COMS (NULL OTHERSFILES))
                          (SETQ OTHERSFILES)
                          (SETQ FNS])]
     (COND
        ((EQ COMS T)
         (CONS OTHERSFILES FNS])

(EDITFROMFILE
  [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES)     (* rmk%: "14-Mar-85 21:51")
    (RESETVARS [(EDITLOADFNSFLG (COND
                                   ((EQ EDITLOADFNSFLG T)
                                    '(T . NO))
                                   (T EDITLOADFNSFLG]
               (PROG NIL
                     [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN]
                     (AND
                      (SETQ FILES (for FILE inside (OR FILES FILELST)
                                     when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE)
                                                                             FILELST))
                                                  (COND
                                                     ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" 
                                                                                        FILE)
                                                                    NIL T))
                                                      (LOADFROM FILE FNS 'ALLPROP)
                                                      T))) collect FILE))
                      (for TYPE in [COND
                                              ((LISTP ONLYTYPES))
                                              (ONLYTYPES '(FNS))
                                              (T 

                                 (* ;; "Move FNS to the front.  This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.")

                                                 (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES]
                         when (AND (LITATOM TYPE)
                                       (NEQ (fetch EDITDEF of TYPE)
                                            'NILL))
                         do
                         (PROG (SEEN)
                               (for FILE inside FILES
                                  do
                                  (for NAME in [COND
                                                          ((AND (EQ TYPE 'FNS)
                                                                (NEQ FNS T))
                                                             (* ; 
                                                    "for this type, we are given the list of items")
                                                           (PROG1 FNS (SETQ FNS NIL)))
                                                          (T (* ; 
                             "only want the values of `TYPE' which are not part of some other type")
                                                             (FILECOMSLST FILE TYPE 'EDIT]
                                     unless (MEMBER NAME SEEN)
                                     do
                                     (ERSETQ
                                      (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT
                                                             '(NOCOPY NOERROR))
                                                      (GETDEF NAME TYPE 'SAVED
                                                             '(NOCOPY NOERROR]

                                 (* ;; "If definition has been loaded, it may have been editted.  Work on that explicitly instead of bringing in a file definition to smash the users previous changes.  Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS.  --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file.  But ...  rmk")

                                            (COND
                                               ((OR (AND (EQ TYPE 'FNS)
                                                         (NEQ FNS T))
                                                    (AND (LISTP DEF)
                                                         (LOOKIN DEF EDITPATTERN)))
                                                (COND
                                                   ((NULL SEEN)
                                                    (LISPXPRIN1 "editing the " T)
                                                    (LISPXPRIN1 (OR (fetch DESCRIPTION
                                                                       of TYPE)
                                                                    TYPE)
                                                           T)
                                                    (LISPXSPACES 1 T)))
                                                (SETQ SEEN (CONS NAME SEEN))
                                                (LISPXPRIN2 NAME T T)
                                                (LISPXPRIN1 ":
" T)
                                                (COND
                                                   ((NOT
                                                     (ERSETQ (EDITDEF
                                                              NAME TYPE
                                                              (OR (AND DEF (CONS '= DEF))
                                                                  FILE)
                                                              EDITCOMS)))
                                                    (LISPXPRIN1 "failed" T)))
                                                (LISPXTERPRI T])

(FINDATS
  [LAMBDA (X L)                                          (* lmm "11-FEB-78 16:03")
    (COND
       ((NLISTP X)
        (FMEMB X L))
       (T (OR (FINDATS (CAR X)
                     L)
              (FINDATS (CDR X)
                     L])

(LOOKIN
  [LAMBDA (X PAT)                                        (* lmm "11-MAR-78 14:20")
    (COND
       ([AND (EQ (CAR PAT)
                 '*ANY*)
             (EVERY (CDR PAT)
                    (FUNCTION (LAMBDA (X)
                                (AND (LITATOM X)
                                     (NOT (STRPOS ' X]
        (FINDATS X (CDR PAT)))
       (T (EDITFINDP X PAT T])
)
(DEFINEQ

(SEPRCASE
  [LAMBDA (CLFLG RDTBL)                                  (* bvm%: "24-Oct-86 18:16")

    (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent.  Based on FILERDTBL, but others are close with respect to breaks and seprs")

    (OR RDTBL (SETQ RDTBL FILERDTBL))
    (OR [ARRAYP (CDR (ASSOC RDTBL (COND
                                     (CLFLG CLISPCASEARRAYS)
                                     (T SEPRCASEARRAYS]
        (LET ((CA (CASEARRAY)))
             [if (READTABLEPROP RDTBL 'CASEINSENSITIVE)
                 then                                    (* ; "map upper into lower case")
                       (for I from (CHARCODE A) to (CHARCODE Z)
                          do (SETCASEARRAY CA I (+ I (- (CHARCODE a)
                                                            (CHARCODE A]
             (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS
                                                    collect (CHCON1 Y)))
                                      (GETSEPR RDTBL)
                                      (GETBRK RDTBL)) do (SETCASEARRAY CA X 0))
             (if *PACKAGE*
                 then                                    (* ; 
                               "symbols qualified with package prefix will otherwise be unfindable")
                       (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR)
                              0))
             (SETQ CA (CONS RDTBL CA))
             (COND
                (CLFLG (push CLISPCASEARRAYS CA))
                (T (push SEPRCASEARRAYS CA)))
             (CDR CA])
)

(RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL))

(RPAQ? SEPRCASEARRAYS )

(RPAQ? CLISPCASEARRAYS )

(MOVD? 'INFILEP 'FINDFILE)

                                                             (* ; "or else from SPELLFILE")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
       (NOLINKFNS LOADFROM))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)
)



(* ; "EXPORT")

(DEFINEQ

(IMPORTFILE
  [LAMBDA (FILE RETURNFLG)                               (* lmm " 6-Jun-86 17:43")
    (RESETLST
        [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT]
        (RESETSAVE (INPUT FILE))                             (* ; 
                "Reset INPUT in case some form on the file's action is to read the next expression")
        (NCONC [COND
                  ((EQ RETURNFLG T)                          (* ; 
                                           "Just creating EXPORTS.ALL, don't side-effect the world")
                   (IMPORTFILESCAN FILE RETURNFLG))
                  (T (LET (FILEPKGFLG DFNFLG)
                          (IMPORTFILESCAN FILE RETURNFLG]
               (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE))
                                     ''IMPORTDATE
                                     (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE]
                      RETURNFLG)))])

(IMPORTEVAL
  [LAMBDA (FORM RETURNFLG)                               (* ; "Edited  2-May-87 18:57 by Pavel")

    (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")

    (AND (LISTP FORM)
         (SELECTQ (CAR FORM)
             (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (/DECLAREDATATYPE                               (* ; 
                    "Ignore datatype initializations -- we only need the record declaration itself")
                  NIL)
             (PROGN                                          (* ; "default: eval and/or return it")
                    (AND (NEQ RETURNFLG T)
                         (EVAL FORM))
                    (AND RETURNFLG (LIST FORM])

(IMPORTFILESCAN
  [LAMBDA (FILE RETURNFLG)                               (* bvm%: "24-Oct-86 19:31")
    (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
        (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
           join (until (EQUAL (SETQ DEF (READ FILE))
                                      ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])

(CHECKIMPORTS
  [LAMBDA (FILES NOASKFLG)                               (* rmk%: "19-FEB-83 16:31")
                                                             (* ; 
                                           "Loads exported definitions from new versions of FILES.")
    (COND
       ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE
                            when [AND (SETQ FULLFILENAME (FINDFILE FILE T))
                                          (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE)
                                                                     'IMPORTDATE]
                                              (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 
                                                                     'ICREATIONDATE]
                            collect (LIST FILE FULLFILENAME)))
             (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from "
                                                       (MAPCAR FILES (FUNCTION CAR)))
                                          '((Y "es
")
                                            (N "o
"))
                                          T)
                              (N NIL)
                              T)))
        (for FILE in FILES do (IMPORTFILE (CADR FILE])

(GATHEREXPORTS
  [LAMBDA (FROMFILES TOFILE FLG)                         (* bvm%: "14-Oct-86 23:12")
                                                             (* ; 
                                        "Copies all exported definitions from FROMFILES to TOFILE.")
    (RESETLST
        [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE)
                             (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT]
        (RESETSAVE (OUTPUT TOFILE))
        (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*))
             (SETQ ENV (if ENV
                           then (\DO-DEFINE-FILE-INFO NIL ENV)
                         else *OLD-INTERLISP-READ-ENVIRONMENT*))
             (WITH-READER-ENVIRONMENT ENV
                 (PRINT-READER-ENVIRONMENT ENV)
                 (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T)
                        " ON "
                        (DATE)
                        "%"  T)" T "(LISPXTERPRI T)" T)
                 (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T))
                                                              (FUNCTION PRINT))
                                                       (TERPRI))
                 (PRINT 'STOP)
                 (TERPRI)
                 (FULLNAME TOFILE))))])

(\DUMPEXPORTS
  [NLAMBDA COMS                                          (* bvm%: "24-Oct-86 19:42")

(* ;;; "Dumps an EXPORT form.  IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.")

    (PRIN1 "(")
    (PRIN2 '*)
    (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2))               (* ; 
                                   "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE")
    (for TAIL on COMS do (PRETTYCOM (CAR TAIL)))
    (TERPRI)
    (PRINT ENDEXPORTDEFFORM)
    (TERPRI])
)
(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X])

(RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")

(RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)
)



(* ; "for GAINSPACE")

(DEFINEQ

(CLEARFILEPKG
  [LAMBDA (FLG)                                          (* bvm%: "29-Aug-86 13:02")
    (PROG NIL
          (COND
             ((SELECTQ FLG
                  ((E T) 
                       T)
                  (Y (TERPRI T)
                     (PRIN1 "you can delete just the filemaps -
" T)
                     (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? "
                                   '((Y "es - everything" RETURN T)
                                     (N "o - just the filemaps" RETURN NIL)
                                     (E "verything" RETURN T)
                                     (F "ilemaps only" RETURN NIL]
                            (TERPRI T)))
                  NIL)
              (UPDATEFILES)
              [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE)
                                                        (COND
                                                           ((fetch TOBEDUMPED
                                                               of (fetch FILEPROP
                                                                         of FILE))
                                                            (PRINT FILE T T)
                                                            (PRIN1 " has changes, not wiped." T)
                                                            (TERPRI T)
                                                            T)
                                                           (T (replace FILEPROP of FILE
                                                                 with NIL)
                                                              (replace FILECHANGES of FILE
                                                                 with NIL)
                                                              (SMASHFILECOMS FILE)
                                                              (NCONC1 SYSFILES FILE)
                                                              NIL]
              (SETQ LOADEDFILELST)))
          (SELECTQ FLG
              ((NIL T))
              (CLRHASH *FILEMAP-HASH*])
)

(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                    ((Y "es")
                                     (N "o")
                                     (E . "verything")
                                     (F "ilemaps only
"))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SMASHPROPSLST1)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST 
       DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS 
       LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG 
       MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS 
       FILEPKGTYPEPROPS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
       (SPECVARS COMSNAME))

(BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
       (NOLINKFNS . T)
       (SPECVARS COMSNAME)
       (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))

(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS 
       INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
       (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
       INFILECOMSPROP)

(BLOCK%: NIL MAKEFILE (LOCALVARS . T)
       (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))

(BLOCK%: ADDFILE ADDFILE ADDFILE0)

(BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))

(BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
       COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF 
       EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE
       FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES 
       MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED 
       MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
       SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF 
       UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS 
                          EDITLOADFNSFLG LOADOPTIONS)
       (LOCALVARS . T))

(BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))

(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
       GETDEFSAVED (RETFNS GETDEFCOM)
       (NOLINKFNS . T)
       (GLOBALVARS NOT-FOUNDTAG))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS 
                          MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS 
                          PRETTYDEFMACROS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1995 2018 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (22908 24613 (SEARCHPRETTYTYPELST 22918 . 23897) (PRETTYDEFMACROS 23899 . 24357) (
FILEPKGCOMPROPS 24359 . 24611)) (25415 59356 (CLEANUP 25425 . 26813) (COMPILEFILES 26815 . 27091) (
COMPILEFILES0 27093 . 27813) (CONTINUEDIT 27815 . 29235) (MAKEFILE 29237 . 40879) (FILECHANGES 40881
 . 43216) (FILEPKG.MERGECHANGES 43218 . 44041) (FILEPKG.CHANGEDFNS 44043 . 44355) (MAKEFILE1 44357 . 
48627) (COMPILE-FILE? 48629 . 49961) (MAKEFILES 49963 . 51656) (ADDFILE 51658 . 54179) (ADDFILE0 54181
 . 58317) (LISTFILES 58319 . 59354)) (60044 95284 (FILEPKGCHANGES 60054 . 61404) (GETFILEPKGTYPE 61406
 . 64479) (MARKASCHANGED 64481 . 66118) (FILECOMS 66120 . 66504) (WHEREIS 66506 . 67926) (
SMASHFILECOMS 67928 . 68163) (FILEFNSLST 68165 . 68327) (FILECOMSLST 68329 . 68813) (UPDATEFILES 68815
 . 74115) (INFILECOMS? 74117 . 76020) (INFILECOMTAIL 76022 . 77162) (INFILECOMS 77164 . 77325) (
INFILECOM 77327 . 87536) (INFILECOMSVALS 87538 . 87865) (INFILECOMSVAL 87867 . 88869) (INFILECOMSPROP 
88871 . 89700) (IFCPROPS 89702 . 90963) (IFCEXPRTYPE 90965 . 91476) (IFCPROPSCAN 91478 . 92531) (
IFCDECLARE 92533 . 93844) (INFILEPAIRS 93846 . 94178) (INFILECOMSMACRO 94180 . 95282)) (95319 126095 (
FILES? 95329 . 97522) (FILES?1 97524 . 98174) (FILES?PRINTLST 98176 . 98958) (ADDTOFILES? 98960 . 
109562) (ADDTOFILE 109564 . 110480) (WHATIS 110482 . 112458) (ADDTOCOMS 112460 . 114104) (ADDTOCOM 
114106 . 120653) (ADDTOCOM1 120655 . 121826) (ADDNEWCOM 121828 . 122878) (MAKENEWCOM 122880 . 124723) 
(DEFAULTMAKENEWCOM 124725 . 126093)) (126165 128982 (MERGEINSERT 126175 . 128518) (MERGEINSERT1 128520
 . 128980)) (130501 141413 (DELFROMFILES 130511 . 131361) (DELFROMCOMS 131363 . 133042) (DELFROMCOM 
133044 . 138912) (DELFROMCOM1 138914 . 139711) (REMOVEITEM 139713 . 140587) (MOVETOFILE 140589 . 
141411)) (141627 143996 (SAVEPUT 141637 . 143994)) (144121 152445 (UNMARKASCHANGED 144131 . 145839) (
PREEDITFN 145841 . 148352) (POSTEDITPROPS 148354 . 150855) (POSTEDITALISTS 150857 . 152443)) (152594 
173148 (ALISTS.GETDEF 152604 . 152983) (ALISTS.WHENCHANGED 152985 . 153629) (CLEARCLISPARRAY 153631 . 
154805) (EXPRESSIONS.WHENCHANGED 154807 . 155181) (MAKEALISTCOMS 155183 . 156256) (MAKEFILESCOMS 
156258 . 157695) (MAKELISPXMACROSCOMS 157697 . 159715) (MAKEPROPSCOMS 159717 . 160415) (
MAKEUSERMACROSCOMS 160417 . 162217) (PROPS.WHENCHANGED 162219 . 162840) (FILEGETDEF.LISPXMACROS 162842
 . 164284) (FILEGETDEF.ALISTS 164286 . 164905) (FILEGETDEF.RECORDS 164907 . 165838) (FILEGETDEF.PROPS 
165840 . 166632) (FILEGETDEF.MACROS 166634 . 167694) (FILEGETDEF.VARS 167696 . 168112) (FILEGETDEF.FNS
 168114 . 169478) (FILEPKGCOMS.PUTDEF 169480 . 171920) (FILES.PUTDEF 171922 . 172879) (VARS.PUTDEF 
172881 . 173024) (FILES.WHENCHANGED 173026 . 173146)) (175170 182603 (RENAME 175180 . 176581) (
CHANGECALLERS 176583 . 182601)) (182604 230552 (SHOWDEF 182614 . 183407) (COPYDEF 183409 . 185883) (
GETDEF 185885 . 188161) (GETDEFCOM 188163 . 189129) (GETDEFCOM0 189131 . 190477) (GETDEFCURRENT 190479
 . 196899) (GETDEFERR 196901 . 198202) (GETDEFFROMFILE 198204 . 202484) (GETDEFSAVED 202486 . 203590) 
(PUTDEF 203592 . 204295) (EDITDEF 204297 . 205274) (DEFAULT.EDITDEF 205276 . 208112) (EDITDEF.FILES 
208114 . 208315) (LOADDEF 208317 . 208493) (DWIMDEF 208495 . 209349) (DELDEF 209351 . 212365) (
DELFROMLIST 212367 . 212871) (HASDEF 212873 . 219195) (GETFILEDEF 219197 . 219719) (SAVEDEF 219721 . 
221380) (UNSAVEDEF 221382 . 222278) (COMPAREDEFS 222280 . 225582) (COMPARE 225584 . 226288) (TYPESOF 
226290 . 230550)) (230619 235662 (FIXEDITDATE 230629 . 234132) (EDITDATE? 234134 . 235660)) (236081 
244667 (FILEPKGCOM 236091 . 241024) (FILEPKGTYPE 241026 . 244665)) (256704 271256 (FINDCALLERS 256714
 . 257229) (EDITCALLERS 257231 . 264889) (EDITFROMFILE 264891 . 270571) (FINDATS 270573 . 270845) (
LOOKIN 270847 . 271254)) (271257 272984 (SEPRCASE 271267 . 272982)) (273501 279043 (IMPORTFILE 273511
 . 274485) (IMPORTEVAL 274487 . 275367) (IMPORTFILESCAN 275369 . 275790) (CHECKIMPORTS 275792 . 277128
) (GATHEREXPORTS 277130 . 278453) (\DUMPEXPORTS 278455 . 279041)) (279381 281589 (CLEARFILEPKG 279391
 . 281587)))))
STOP
\ No newline at end of file
diff --git a/sources/FILEPKG.~12~ b/sources/FILEPKG.~12~
deleted file mode 100644
index cafb9363..00000000
--- a/sources/FILEPKG.~12~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "27-Oct-2020 15:40:32" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;12 285044 

      changes to%:  (FNS MAKEFILE1 COMPILE-FILE?)

      previous date%: "10-Aug-2020 21:24:58" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;11)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020 by Venue & Xerox Corporation.  All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")

(PRETTYCOMPRINT FILEPKGCOMS)

(RPAQQ FILEPKGCOMS
       [(COMS                                                (* ; 
            "standard records for accessing file  package type/command parts.  Exported for PRETTY")
              (VARS FILEPKGTYPEPROPS)
              (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
              (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
              (INITRECORDS * FILEPKGRECORDS))
        [DECLARE%: EVAL@COMPILE DOCOPY 

               (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.")

               (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES 
                                       PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS
                                       PRETTYFLG))
                  (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES 
                                       NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS]
        (INITVARS (MSDATABASELST))
        [COMS 
              (* ;; "making, adding, listing, compiling files")

              (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES 
                   FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE
                   ADDFILE0 LISTFILES)
              (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
                     (FILELST)
                     (LOADEDFILELST)
                     (NOTLISTEDFILES)
                     (NOTCOMPILEDFILES)
                     (MAKEFILEFORMS)
                     (NILCOMS))
              (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% 
                              F ST STF (REC . RC)
                              (BREC . RC)
                              (TC . C)
                              (BC . C)
                              (TCOMPL . C)
                              (BCOMPL . C)))
              (INITVARS (MAKEFILEREMAKEFLG T)
                     (CLEANUPOPTIONS '(RC]
        (COMS 
              (* ;; "scanning file coms")

              (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS 
                   FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM
                   INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                   IFCDECLARE INFILEPAIRS INFILECOMSMACRO))
        (COMS 
              (* ;; "adding to a file")

              (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM 
                   ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM)
              (INITVARS (DEFAULTCOMHASFILEFLG))
              (ADDVARS (MARKASCHANGEDFNS))
              (FNS MERGEINSERT MERGEINSERT1)
              
              (* ;; "RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file")

              (VARS [ADDTOFILEKEYLST `(("[" "" EXPLAINSTRING 
                                           "[ -- prettyprint the item to terminal and then ask again"
                                            NOECHOFLG T)
                                       (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG
                                          T)
                                       (,(CHARACTER (CHARCODE LF))
                                        "" EXPLAINSTRING "{line-feed} - same as previous response" 
                                        NOECHOFLG T)
                                       (" " ,(CONCATCODES (LIST (CHARCODE SPACE)
                                                                (CHARCODE EOL)))
                                            EXPLAINSTRING "{space} - no action" NOECHOFLG T)
                                       ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
                                            EXPLAINSTRING
                                            ,(CONCAT "] - nowhere, item is marked as a dummy"
                                                    (CHARACTER (CHARCODE EOL)))
                                            NOECHOFLG T)
                                       ["(" "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
                                            (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE))
                                                                 ,(CHARACTER (CHARCODE EOL]
                                                RETURN
                                                (CDR ANSWER]
                                       (@ "Near: " EXPLAINSTRING 
                                          "@ other-item   -- put the item near the other item" 
                                          NOECHOFLG T KEYLST (( "" CONFIRMFLG
                                                                 [,(CHARACTER (CHARCODE EOL]
                                                                 RETURN ANSWER)))
                                       [,(CHARACTER (CHARCODE CR))
                                        "" RETURN ,(CHARACTER (CHARCODE SPACE]
                                       ("" "File name: " EXPLAINSTRING "a file name" KEYLST (]
                    (LASTFILE)))
        (COMS 
              (* ;; "deleting an item from a file")

              (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE)
              (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
                 (MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
              (ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
        [COMS                                                (* ; 
                      "functions for doing things and marking them changed and auxiliary functions")
              (FNS SAVEPUT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
                                                     (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
              (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
              (ADDVARS (LISPXFNS (PUT . SAVEPUT)
                              (PUTPROP . SAVEPUT]
        (COMS                                                (* ; 
                                                  "sub-functions for file package commands & types")
              (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED 
                   MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS 
                   PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS 
                   FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS 
                   FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED)
              (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO)
                     (SYSPROPS PROPTYPE))
              (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT 
                    FILETYPE)
              (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS 
                    LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS 
                    PRETTYPRINTYPEMACROS USERMACROS))
        (COMS                                                (* ; 
                    "Define the commands below AFTER the various properties have been established.")
              (USERMACROS M))
        (COMS                                                (* ; "GETDEF methods")
              (FNS RENAME CHANGECALLERS)
              (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
                   GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF 
                   DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
              (INITVARS (WHEREIS.HASH)))
                                                             (* ; "Must come after PUTDEF")
        (FNS FIXEDITDATE EDITDATE?)
                                                             (* ; 
                                  "Edit date support for all kinds of definers (from PARC 6/10/92)")
        [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
              (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
        (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
        (COMS 
              (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")

              (FNS FILEPKGCOM FILEPKGTYPE)
              (PROP ARGNAMES FILEPKGCOM)
              (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
                     (FILEPKGTYPES FILEPKGCOMS))
              (FILEPKGCOMS FILEPKGCOMS)
              (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS
                     INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS
                     OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS))
        (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS)
                        (VARIABLES VARS CONSTANTS)))
        (INITVARS (SAVEDDEFS))
        (COMS                                                (* ; "EDITCALLERS")
              (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
              (FNS SEPRCASE)
              [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL]
              (INITVARS (SEPRCASEARRAYS)
                     (CLISPCASEARRAYS))
              (P (MOVD? 'INFILEP 'FINDFILE)
                                                             (* ; "or else from SPELLFILE"))
              (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
                             (NOLINKFNS LOADFROM)))
              (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS))
        (COMS                                                (* ; "EXPORT")
              (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS)
              (FILEPKGCOMS EXPORT)
              [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
                     (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"]
              (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM))
        (COMS                                                (* ; "for GAINSPACE")
              (FNS CLEARFILEPKG)
              [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                              ((Y "es")
                                               (N "o")
                                               (E . "verything")
                                               (F "ilemaps only
"]
              (GLOBALVARS SMASHPROPSLST1))
        (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT 
               DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 
               I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS 
               MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS 
               SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS)
        (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
                       (SPECVARS COMSNAME))
               (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
                      (NOLINKFNS . T)
                      (SPECVARS COMSNAME)
                      (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
               (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL 
                      INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                      IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
                      INFILECOMSPROP)
               (NIL MAKEFILE (LOCALVARS . T)
                    (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
               (ADDFILE ADDFILE ADDFILE0)
               (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
               (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
                    COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES 
                    EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM 
                    FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL 
                    LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS 
                    MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE 
                    POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
                    SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED 
                    UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS 
                                                 COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
                    (LOCALVARS . T))
               (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
               (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
                      GETDEFSAVED (RETFNS GETDEFCOM)
                      (NOLINKFNS . T)
                      (GLOBALVARS NOT-FOUNDTAG)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS 
                               MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP 
                               FILEPKGCOMPROPS PRETTYDEFMACROS)
                      (NLAML)
                      (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES])



(* ; "standard records for accessing file  package type/command parts.  Exported for PRETTY")


(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF CANFILEDEF FILEGETDEF))
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(DECLARE%: EVAL@COMPILE

(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
                                               (T (/REMPROP DATUM 'PRETTYTYPE]
                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
                                  (STANDARD [COND
                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
                                                                (OR (LISTP (GETTOPVAL 
                                                                                  'PRETTYDEFMACROS))
                                                                    (SETTOPVAL 'PRETTYDEFMACROS
                                                                           (LIST (LIST DATUM]
                                               (T (SETTOPVAL 'PRETTYDEFMACROS
                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
                                                                                'PRETTYDEFMACROS))
                                                                (GETTOPVAL 'PRETTYDEFMACROS]
                                         UNDOABLE
                                         (COND
                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
                                                                        (LIST (LIST DATUM]
                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
                                                                                   'PRETTYDEFMACROS))
                                                             (GETTOPVAL 'PRETTYDEFMACROS]
                                                             (* Not an atom record cause want 
                                                           REMPROP on NILs.)
                                                             (* NOTE%: PRETTCOM on PRETTY has 
                                                           open-coded access to the MACRO 
                                                           property.)
                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
                                       FILEPKGCONTENTS)))

(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
                                                           )
                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
                                                                              DATUM)))
                                                           (STANDARD (SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                      DATUM NEWVALUE)
                                                                                     )
                                                                            NEWVALUE)
                                                                  UNDOABLE
                                                                  (/SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                    DATUM NEWVALUE))
                                                                         NEWVALUE)))
                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
                                                                             DATUM)))
                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
                                                                               DATUM NEWVALUE))
                                                                       NEWVALUE)))
                                                    (ALLFIELDS NIL (/SETTOPVAL
                                                                    'PRETTYTYPELST
                                                                    (REMOVE (SEARCHPRETTYTYPELST
                                                                             DATUM)
                                                                           (GETTOPVAL 'PRETTYTYPELST]
                                                             (* NOTE%: PRETTYCOM on PRETTY has 
                                                           open-coded access to GETDEF property)
                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                                                                   (PUT X
                                                                                        'PROPTYPE
                                                                                        'FILEPKGCOMS]
                                         (ADDTOVAR PRETTYTYPELST ))))

(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
                                                    UNDOABLE
                                                    (/PUTPROP DATUM 'FILE NEWVALUE])

(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))

(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
)

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
)

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(SEARCHPRETTYTYPELST
  [LAMBDA (TYPE FLG)                                     (* rmk%: " 3-JAN-82 22:55")
                                                             (* ; 
                                                           "access functions used by the records")
    (AND (LITATOM TYPE)
         (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X)
                                                               TYPE))
             (COND
                (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE
                                                                             'LST)
                                                                      TYPE NIL))
                                                      (GETTOPVAL 'PRETTYTYPELST]
                     (OR (LISTP (GETTOPVAL (CAR FLG)))
                         (/SETTOPVAL (CAR FLG)
                                NIL))
                     FLG])

(PRETTYDEFMACROS
  [NLAMBDA ARGS                                          (* lmm " 5-SEP-78 16:16")
                                                             (* ; 
                                                 "included so that old files will continue to load")
    (for X in ARGS collect (FILEPKGCOM (CAR X)
                                              'MACRO
                                              (CDR X])

(FILEPKGCOMPROPS
  [NLAMBDA PROPS
    (MAPC PROPS (FUNCTION (LAMBDA (Y)
                            (OR (MEMB Y SYSPROPS)
                                (SETQ SYSPROPS (CONS Y SYSPROPS)))
                            (PUT Y 'PROPTYPE 'FILEPKGCOMS])
)

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS 
                     *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG))

(CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS 
                     CLEANUPOPTIONS))
)

(RPAQ? MSDATABASELST )



(* ;; "making, adding, listing, compiling files")

(DEFINEQ

(CLEANUP
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (PROG (TEM1 TEM2 OPTIONS)
          (COND
             ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
              (SETQ OPTIONS (CAR FILES))
              (SETQ FILES (CDR FILES)))
             (T (SETQ OPTIONS CLEANUPOPTIONS)))
          (RETURN (APPEND (MAKEFILES OPTIONS FILES)
                         (COND
                            ((NOT (MEMB 'LIST OPTIONS))
                             NIL)
                            ((NULL FILES)
                             (LISTFILES))
                            ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES))
                                                             (* ; 
            "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.")
                             (APPLY 'LISTFILES TEM1)))
                         (COND
                            [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS]
                            ((NULL FILES)
                             (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES)
                                    (CDR TEM1))
                             TEM2)
                            ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES))
                             (COMPILEFILES0 TEM2 (CDR TEM1))
                             TEM2])

(COMPILEFILES
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (COND
       ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
        (COMPILEFILES0 (CDR FILES)
               (CAR FILES)))
       (T (COMPILEFILES0 FILES])

(COMPILEFILES0
  [LAMBDA (FILES OPTIONS)                                (* rmk%: "19-FEB-83 21:59")
    (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES)
       first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS))
                                (C (SETQ RCFLG NIL)
                                   (CDR OPTIONS))
                                (RC (CDR OPTIONS))
                                OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X)
                                                                           70 FILELST NIL X)
                                                                    (CAR X))
                                                        RCFLG OPTS X])

(CONTINUEDIT
  [LAMBDA (FILE)                                         (* bvm%: "30-Aug-86 15:09")
    (PROG (STREAM FL TEM FC ENV)
          (RESETLST
              [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT]
              (SETQ FILE (FULLNAME STREAM))
              (SETFILEPTR STREAM 0)
              (CL:MULTIPLE-VALUE-SETQ (ENV FC)
                     (\PARSE-FILE-HEADER STREAM 'RETURN)))
          (COND
             ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE]
              (LOADFROM FILE)                                (* ; 
                                                           "also calls addfile to notice the file.")
              ))
          (/replace FILECHANGES of FL with (FILECHANGES FC))
          [/replace FILEDATES of FL with
                                            (LIST (create FILEDATEPAIR
                                                         FILEDATE _ (CADR FC)
                                                         DATEFILENAME _ FILE)
                                                  (create FILEDATEPAIR
                                                         FILEDATE _
                                                         [CAR (SETQ TEM (CDR (MEMB 'date%: FC]
                                                         DATEFILENAME _ (CADR TEM]
          (RETURN FILE])

(MAKEFILE
  [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)           (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL;  LIST means list the FILE;  RC means RECOMPILE, C means COMPILEL;  --- for C AND RC assume ST unless next option is F.")

    (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS]
                           PRETTYFLG))
           (*PRINT-BASE* (if (EQ *PRINT-BASE* 8)
                             then 8
                           else                          (* ; "make sure radix is either 8 or 10, because all others don't read in like they print.  Maybe obsolete now with makefile environments")
                                 10))
           FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
          (DECLARE (CL:SPECIAL PRETTYFLG))
          (SETQ FILE (CAR Z))                                (* ; 
                                               "Necessary because FILE might have been misspelled.")
          (SETQ ROOTNAME (CADR Z))                           (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.")
          (SETQ FILEPROP (CDDR Z))
          (UPDATEFILES)                                  (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.")
          (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
          (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
          (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE))
      LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
                       (NULL FILEDATES))
              then                                       (* ; 
                   "File has never been loaded and never dumped i.e. user just set up COMS in core")
            elseif [OR (EQMEMB 'NEW OPTIONS)
                           (AND (NULL MAKEFILEREMAKEFLG)
                                (NOT (MEMB 'REMAKE OPTIONS]
              then (COND
                          ((AND (fetch LOADTYPE of FILEPROP)
                                (NEQ T (fetch LOADTYPE of FILEPROP)))
                           (LISPXPRIN2 FILE T T)
                           (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
                                           (LOADCOMP 
                                                  "the file was loaded for compilation purposes only")
                                           ((compiled Compiled COMPILED) 
                                                " -- only the compiled file has been loaded
")
                                           ((loadfns LOADFNS) 
                                                " -- only some of its symbolics have been loaded
")
                                           (SHOULDNT))
                                  T)
                           (COND
                              ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ")
                                    'Y)                      (* ; 
            "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.")
                               (GO OUT)))
                           (/replace LOADTYPE of FILEPROP with NIL)))
                    (SETQ SOURCEFILE NIL)
                    (SETQ REPRINTFNS NIL)
            elseif SOURCEFILE
              then                                       (* ; "source file given")
            elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T))
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
                                          (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE
                                                                              (fetch DATEFILENAME
                                                                                 of (CAR 
                                                                                            FILEDATES
                                                                                             ]
                                               (INFILEP SOURCEFILE)
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
              then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
                    (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
            elseif [AND (CDR FILEDATES)
                            [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
                            (EQUAL (FILEDATE SOURCEFILE)
                                   (fetch FILEDATE of (CADR FILEDATES]
              then 

                    (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.")

                    (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
                                         (fetch FILECHANGES of ROOTNAME)))
                    (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
            else (LISPXPRIN1 
                            '"can't find either the previous version or the original version of 
" T)
                  (LISPXPRIN2 FILE T T)
                  (LISPXPRIN1 '", so it will have to be written anew
" T)
                  (SETQ SOURCEFILE NIL)
                  (SETQ REPRINTFNS NIL)
                  (push OPTIONS 'NEW)
                  (SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
                  (GO LP0))
          (COND
             ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
                                          (LOADCOMP          (* ; 
                                                   "only loaded via LOADCOMP.  Need to do LOADFROM")
                                                    (LIST 'N SOURCEFILE "was loaded with LOADCOMP"
                                                          '- "LOADFROM it to obtain VARS/COMS"))
                                          (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%:
                                                                (fetch COMSNAME of FILEPROP))
                                                         (LIST 'Y "only compiled version of" ROOTNAME
                                                               
                                        "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions"
                                                               )))
                                          ((compiled loadfns) 
                                               (LIST 'N "Only some functions from" SOURCEFILE 
                                             "loaded via LOADFNS. Load all other expressions from it"
                                                     ))
                                          NIL)))
              (SELECTQ [ASKUSER DWIMWAIT (CAR Z)
                              (CDR Z)
                              '((Y "es
")
                                (N "o
")
                                (A "bort MAKEFILE
"]
                  (Y (SELECTQ (fetch LOADTYPE of FILEPROP)
                         (LOADCOMP                           (* ; 
                               "file was never actually loaded, just loadcomped.  thus no filecoms")
                                   (LOADFROM SOURCEFILE))
                         (Compiled 

                                 (* ;; "This is going to be a remake.  If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.")

                                   (LOADVARS 'DONTCOPY SOURCEFILE)
                                   (/replace LOADTYPE of FILEPROP with 'COMPILED)
                                                             (* ; "So wont have to be done again.")

                                 (* ;; "These are the only DECLARE:'s that are not also on the compiled file.  Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE:  Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)")

                                   )
                         ((loadfns compiled) 

                                 (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.")

                              (LOADVARS T SOURCEFILE))
                         NIL))
                  (A (GO OUT))
                  NIL)))
          (RESETLST
              [COND
                 ((MEMB 'NOCLISP OPTIONS)
                  (RESETSAVE PRETTYTRANFLG T))
                 ((MEMB 'CLISP%  OPTIONS)
                  (RESETSAVE PRETTYTRANFLG 'BOTH]
              (RESETSAVE %#UNDOSAVES)
              [COND
                 ((OR (MEMB 'CLISPIFY OPTIONS)
                      (MEMB 'CLISP OPTIONS))
                  (RESETSAVE CLISPIFYPRETTYFLG T))
                 ((OR (EQ FILETYPE 'CLISP)
                      (MEMB 'CLISP (LISTP FILETYPE)))
                  (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES]
              (for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
              (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
                                REPRINTFNS SOURCEFILE CHANGES)))
          (SETQ LASTFILE ROOTNAME)
          (/replace TOBEDUMPED of FILEPROP with NIL)
          (COND
             ((NOT (EQMEMB 'DON'TLIST FILETYPE))
              (pushnew NOTLISTEDFILES ROOTNAME)))
          (COND
             ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE))
              (pushnew NOTCOMPILEDFILES ROOTNAME)))
          [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL))
                                                 (SELECTQ OPT
                                                     (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                              (MAKEFILE1 FILE T (CDR TAIL))))
                                                     (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                             (MAKEFILE1 FILE NIL (CDR TAIL))))
                                                     (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
                                                                (APPLY 'LISTFILES (LIST FILE))))
                                                     (COND
                                                        ((MEMB OPT MAKEFILEOPTIONS))
                                                        ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL 
                                                                OPTIONS)
                                                         (GO $$LP))
                                                        (T (ERROR "Unrecognized MAKEFILE option" OPT]
          (RETURN FILE)
      OUT (RETURN (LIST FILE "-- MAKEFILE not performed."])

(FILECHANGES
  [LAMBDA (FILE TYPE)                                    (* bvm%: "30-Aug-86 15:08")

    (* ;; "If FILE is a list, it is assumed to be a file-created expressions;  otherwise, the filecreated expression is read from FILE.  If TYPE, returns the list of changed items of that type from the changes expression.  If TYPE=NIL, returns the whole list of typed change-lists")

    (PROG ([FCEXPR (OR (LISTP FILE)
                       (AND FILE (RESETLST
                                     (LET (OLDPTR STREAM)
                                          [if (SETQ STREAM (OPENP FILE 'INPUT))
                                              then (SETQ OLDPTR (GETFILEPTR STREAM))
                                                    (SETFILEPTR STREAM 0)
                                            else (RESETSAVE NIL (LIST 'CLOSEF
                                                                          (SETQ STREAM
                                                                           (OPENSTREAM FILE
                                                                                  'INPUT]
                                          (CL:MULTIPLE-VALUE-BIND (ENV FC)
                                                 (\PARSE-FILE-HEADER STREAM 'RETURN)
                                                 (if OLDPTR
                                                     then (SETFILEPTR STREAM OLDPTR))
                                                 FC)))]
           FNS CHANGES)
          (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR)))
                               (MEMB 'previous CHANGES)))
          [if (AND TYPE (NEQ TYPE 'FNS))
              then (RETURN (CDR (ASSOC TYPE CHANGES]
          (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM)))     (* ; 
                         "Old style changes expression listed FNS by name and other things by type")
          (RETURN (if TYPE
                      then                               (* ; "TYPE=FNS cause of test above.")
                            (NCONC FNS (CDR (ASSOC 'FNS CHANGES)))
                    elseif FNS
                      then (CONS (CONS 'FNS FNS)
                                     (SUBSET CHANGES (FUNCTION LISTP)))
                    else CHANGES])

(FILEPKG.MERGECHANGES
  [LAMBDA (C1 C2)                                        (* rmk%: "24-MAY-82 23:09")

    (* ;; "Merges 2 changes lists into a single one.  Treat LITATOM's as FNS, to accomodate old-style format on files.")

    (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND
                                                                                         E1)))
       in C2 do [COND
                           ((SETQ TEMP (ASSOC (CAR E2)
                                              VAL))
                            (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP))
                                           collect X)))
                           (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL])

(FILEPKG.CHANGEDFNS
  [LAMBDA (CHANGES)                                      (* rmk%: "20-MAY-82 22:00")

    (* ;; "Returns list of function names from a file-changes list.  Interprets old format (functions are atoms) and new format (with explicit type headers)")

    (CDR (ASSOC 'FNS CHANGES])

(MAKEFILE1
  [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES)           (* ; "Edited 27-Oct-2020 15:40 by rmk:")
                                                             (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "RMK:  Call COMPILE-FILE? with FILE instead of (ROOTFILENAME FILE)")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           (COMPILER (COMPILE-FILE? FILE))
           GROUP)
          (COND
             ((AND (OR (EQ COMPILER 'BCOMPL)
                       (EQ COMPILER 'TCOMPL))
                   (NOT (FILEFNSLST ROOTNAME)))          (* ; 
                 "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.")
              (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
              (RETURN NIL)))
          (COND
             ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP))
                 suchthat (AND (NEQ X ROOTNAME)
                                   (OR (fetch TOBEDUMPED of (fetch FILEPROP of X))
                                       (MEMB X OTHERFILES]

              (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled.  Wait.")

              (RETURN)))
          (LISPXPRIN1 '"
compiling " T)
          (LISPXPRINT (OR GROUP FILE)
                 T T)
          (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS)
                                               'ST)
                                           (EQ (CAR OPTIONS)
                                               'STF]
                            (FORGET-EXPRS? (EQ (CAR OPTIONS)
                                               'STF]
                           (SELECTQ COMPILER
                               ((FAKE-COMPILE-FILE)          (* ; 
                                               "The old CommonLispy interface to the ByteCompiler.")
                                    (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS
                                           (AND REDEFINE? (NOT FORGET-EXPRS?))))
                               ((CL:COMPILE-FILE)            (* ; "The new, improved (?) compiler")
                                    (CL:COMPILE-FILE FILE :LOAD (COND
                                                                   ((AND REDEFINE? (NOT FORGET-EXPRS?
                                                                                        ))
                                                                    :SAVE)
                                                                   (REDEFINE? T)
                                                                   (T NIL))))
                               ((TCOMPL BCOMPL)              (* ; "The old ByteCompiler")
                                    [IF (MEMB (CAR OPTIONS)
                                                  '(ST F S STF))
                                        THEN (LISPXUNREAD (LIST (CAR OPTIONS]
                                    [IF GROUP
                                        THEN 

                                              (* ;; 
                                   "File contained in FILEGROUP.  Therefore must be blockcompiled.")

                                              (IF RECOMPFLG
                                                  THEN (BRECOMPILE GROUP)
                                                ELSE (BCOMPL GROUP))
                                      ELSEIF (EQ COMPILER 'TCOMPL)
                                        THEN (IF RECOMPFLG
                                                     THEN (RECOMPILE FILE)
                                                   ELSE (TCOMPL (LIST FILE)))
                                      ELSE (IF RECOMPFLG
                                                   THEN (BRECOMPILE FILE)
                                                 ELSE (BCOMPL (LIST FILE])
                               (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?...")))
                 T T])

(COMPILE-FILE?
  [LAMBDA (FILE)                                        (* ; "Edited 27-Oct-2020 15:39 by rmk:")
                                                             (* ; "Edited 19-Jan-87 21:12 by Pavel")

    (* ;; "RMK: Argument is FILE instead of ROOTFILENAME, maybe more information")

(* ;;; "Which compiler should CLEANUP use?")

    (LET ((TYPE (GET (ROOTFILENAME FILE)
                     'FILETYPE))
          (UNKNOWN NIL))
         (FOR X INSIDE TYPE DO (SELECTQ X
                                               ((TCOMPL :TCOMPL) 
                                                    (RETURN 'TCOMPL))
                                               ((BCOMPL :BCOMPL) 
                                                    (RETURN 'BCOMPL))
                                               ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) 
                                                    (RETURN 'FAKE-COMPILE-FILE))
                                               ((:COMPILE-FILE :XCL-COMPILE-FILE) 
                                                    (RETURN 'CL:COMPILE-FILE))
                                               ((CLISP) 
                                                    NIL)
                                               (SETQ UNKNOWN T))
            FINALLY (IF UNKNOWN
                            THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE
                                            ))
                  (RETURN *DEFAULT-CLEANUP-COMPILER*])

(MAKEFILES
  [LAMBDA (OPTIONS FILES)                                (* rmk%: "23-FEB-83 21:20")
    (RESETVARS (%#UNDOSAVES)                                 (* ; 
                                                   "Willing to save arbitrary amounts of undo info")
               (UPDATEFILES)
               [COND
                  ((NULL FILES)
                   (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE
                                                                         (COND
                                                                            ((NULL FLG)
                                                             (* ; "Gets printed the first time")
                                                                             
                                                                             '
                                        "****NOTE: the following are not contained on any file:
    ")
                                                                            (T '"    "]
                      do (SETQ FLG T) finally (AND FLG (ADDTOFILES?]
               (SETQ OPTIONS (MKLIST OPTIONS))
               (RETURN (for FILE inside (OR FILES FILELST)
                          when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP
                                                                          of (ROOTFILENAME FILE]
                          collect (LISPXPRIN2 FILE T T)
                                (LISPXPRIN1 '|...| T)
                                (PROG1 (MAKEFILE FILE OPTIONS)
                                       (LISPXTERPRI T])

(ADDFILE
  [LAMBDA (FILE LOADTYPE PRLST FCLST)                    (* bvm%: "29-Aug-86 12:22")

    (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           FLST VAL)
          [COND
             ((NOT FCLST)
              (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE)))
             [(NULL (CDR FCLST))                             (* ; "A simple symbolic file")
              (SETQ FCLST (CAR FCLST))
              (SETQ VAL (ADDFILE0 (COND
                                         ((LITATOM (CADR FCLST))
                                          (ROOTFILENAME (CADR FCLST)))
                                         (T ROOTNAME))
                               LOADTYPE FILE (CAR FCLST]
             (T 
                (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.")

                (SELECTQ LOADTYPE
                    ((T LOADFNS) 
                         (SETQ LOADTYPE 'Compiled))
                    (loadfns (SETQ LOADTYPE 'compiled))
                    (LOADCOMP                                (* ; 
                   "loadcomp on compiled file.  Don't notice since we don't know what its state is")
                              NIL)
                    (SHOULDNT))
                (for X in (CDR FCLST) when (LITATOM (CADR X))
                   do (push FLST (CADR X))
                         (OR (EQ LOADTYPE 'LOADCOMP)
                             (ADDFILE0 (ROOTFILENAME (CADR X))
                                    LOADTYPE
                                    (CADR X)
                                    (CAR X]
          (UPDATEFILES PRLST (OR FLST (LIST FILE)))
          [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES
                           when (AND (LITATOM TYPE)
                                         (SETQ CHANGED (fetch CHANGED of TYPE)))
                           do (/replace CHANGED of TYPE
                                     with (INTERSECTION (CDR (ASSOC TYPE PRLST))
                                                     CHANGED]
          (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS))
          (RETURN VAL])

(ADDFILE0
  [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT)               (* lmm "28-Nov-84 16:47")
    (PROG (COMS X FILEPROP FLG TEM)
      TOP (SETQ COMS (FILECOMS ROOTNAME))
          [COND
             ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME))
              (COND
                 ([AND LOADTYPE (FMEMB LOADTYPE
                                       (CDR (FMEMB (fetch LOADTYPE of FILEPROP)
                                                   '(LOADCOMP loadfns compiled Compiled LOADFNS 
                                                           COMPILED NIL T]
                  (/replace LOADTYPE of FILEPROP with LOADTYPE)

                  (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property.  'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file.  'Compiled' means all but DECLARE: expressions are in.  e.g. user does LOAD of a compiled file.  COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.  LOADFNS means everything in, e.g. user des LOADFROM symbolic file.  COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted.  NIL is a makefile when coms were set up in core.  T is full load of symbolic file.  The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.")

                  (* ;; "LOADCOMP means file was loadcomp'ed.  note that the actual structure is a tree, not a list, and the above is only an approximation.  if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc.  however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.")

                  (GO OUT))
                 (T (GO OUT1]
          (COND
             [(OR LOADTYPE (LISTP (GETTOPVAL COMS)))
              (SETQ FILEPROP (/replace FILEPROP of ROOTNAME
                                with (create FILEPROP
                                                COMSNAME _ COMS
                                                LOADTYPE _ LOADTYPE]
             (FLG (GO ERROR))
             ((AND DWIMFLG (EQ ROOTNAME FULLNAME)
                   (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T)))

              (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.")

              (SETQ FULLNAME ROOTNAME)
              (SETQ FLG T)                                   (* ; 
                                         "so wont try to spelling correct again if file isnt there")
              (GO TOP))
             (T (GO ERROR)))
      OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME
                               with (LIST (create FILEDATEPAIR
                                                     FILEDATE _ DAT
                                                     DATEFILENAME _ FULLNAME]
          (AND (EQ LOADTYPE T)
               (/replace TOBEDUMPED of FILEPROP with NIL))
      OUT1
          [COND
             ([AND (LISTP (GETTOPVAL COMS))
                   (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ; 
                                                          "coms wuld not be set up on a loadccomp.")
              (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST]
          (RETURN (COND
                     ((NULL LOADTYPE)                        (* ; "call from makefile.")
                      (CONS FULLNAME (CONS ROOTNAME FILEPROP)))
                     (T FILEPROP)))
      ERROR
          (ERROR FULLNAME "not file name." T])

(LISTFILES
  [NLAMBDA FILES                                         (* rmk%: " 3-Dec-84 08:58")
    (DECLARE (GLOBALVARS NOTLISTEDFILES))                (* ; "LISTFILES1 is machinedependent")
    (for FILE FULLNAME OPTIONS in (COND
                                             (FILES (SETQ FILES (NLAMBDA.ARGS FILES)))
                                             (T NOTLISTEDFILES))
       when (COND
                   ((LISTP FILE)
                    (SETQ OPTIONS (APPEND FILE OPTIONS))
                    NIL)
                   ((SETQ FULLNAME (FINDFILE FILE))
                    FULLNAME)
                   (T (printout T FILE " not found." T)
                      NIL)) collect [COND
                                           ((LISTFILES1 FULLNAME OPTIONS)
                                            (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
                                                                        NOTLISTEDFILES]
                                  FULLNAME])
)

(RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)

(RPAQ? FILELST )

(RPAQ? LOADEDFILELST )

(RPAQ? NOTLISTEDFILES )

(RPAQ? NOTCOMPILEDFILES )

(RPAQ? MAKEFILEFORMS )

(RPAQ? NILCOMS )

(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP%  F ST STF
                                 (REC . RC)
                                 (BREC . RC)
                                 (TC . C)
                                 (BC . C)
                                 (TCOMPL . C)
                                 (BCOMPL . C))

(RPAQ? MAKEFILEREMAKEFLG T)

(RPAQ? CLEANUPOPTIONS '(RC))



(* ;; "scanning file coms")

(DEFINEQ

(FILEPKGCHANGES
  [LAMBDA N                                              (* Pavel " 7-Oct-86 19:22")
    (COND
       [(EQ N 0)
        (PROG (TEM)
              (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X)
                                                                   (SETQ TEM (FILEPKGCHANGES
                                                                              X)))
                         collect (CONS X TEM]
       [(EQ (ARG N 1)
            T)
        (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES
                                                                                 X]
       [(EQ N 1)
        (COND
           [(LISTP (ARG N 1))
            (for X in (ARG N 1) when (FMEMB (CAR X)
                                                        FILEPKGTYPES)
               do (/replace CHANGED of (CAR X) with (CDR X]
           (T (for Y on (fetch CHANGED of (ARG N 1))
                 when [AND (CAR Y)
                               (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y)
                                                                                 Z]
                 collect (CAR Y]
       (T (/replace CHANGED of (ARG N 1) with (ARG N 2])

(GETFILEPKGTYPE
  [LAMBDA (TYPE ONLY NOERROR NAME)                       (* lmm "20-Nov-86 23:10")

    (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ")

    (COND
       [(LISTP TYPE)

        (* ;; " given a list of types, coerce them all or return NIL")

        (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME)
                                               (RETURN]
       ((EQ TYPE '?)

        (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ")

        (AND NAME (TYPESOF NAME)))
       [(AND (NEQ ONLY 'COMS)
             (OR (SELECTQ TYPE
                     (NIL 'FNS)
                     (T 'VARS)
                     NIL)
                 (for X in FILEPKGTYPES do (if (EQ TYPE X)
                                                           then 

                                                                 (* ;; "type matched exactly")

                                                                 (RETURN TYPE)
                                                         elseif (AND (LISTP X)
                                                                         (EQ TYPE (CAR X)))
                                                           then (RETURN (CDR X]
       [(AND (NEQ ONLY 'TYPE)
             (LITATOM TYPE)
             (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST))       (* ; "Prefer an exact match quickly")
                    ]
       [(AND (NEQ ONLY 'COMS)
             (LITATOM TYPE)
             (for X in FILEPKGTYPES bind NAME
                do (SETQ NAME (if (NLISTP X)
                                      then X
                                    else (CAR X))) 

                      (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization")

                      (AND (<= 0 (- (NCHARS NAME)
                                    (NCHARS TYPE))
                               1)
                           (STRPOS TYPE NAME)
                           (RETURN (if (EQ X NAME)
                                       then X
                                     else (CDR X]
       [(FIXSPELL TYPE NIL (SELECTQ ONLY
                               (TYPE FILEPKGTYPES)
                               (COMS FILEPKGCOMSPLST)
                               (UNION FILEPKGTYPES FILEPKGCOMSPLST]
       ((NOT NOERROR)
        (ERROR (SELECTQ ONLY
                   (TYPE "unrecognized manager definition type")
                   (COMS "unrecognized manager command")
                   "unrecognized manager definition-type/command")
               TYPE])

(MARKASCHANGED
  [LAMBDA (NAME TYPE REASON)                             (* ; "Edited 25-May-88 15:37 by drc:")
    (COND
       (FILEPKGFLG (SETQ REASON (SELECTQ REASON
                                    ((CLISP LOAD CHANGED DEFINED DELETED) 
                                         REASON)
                                    (NIL 'CHANGED)
                                    (T 'DEFINED)
                                    (ERROR "bad REASON in MARKASCHANGED" REASON)))
              (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (for FN inside (fetch WHENCHANGED of TYPE)
                 do (APPLY* FN NAME TYPE REASON))
              (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON))
              [COND
                 ((EQ REASON 'DELETED)
                  (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L)
                                                                                    NAME)
                     do (/RPLACA L NIL))                 (* ; 
                                                          "unmark as changed and remove from files")
                  (DELFROMFILES NAME TYPE))
                 (T (LET ((LST (push (fetch CHANGED of TYPE)
                                      NAME)))
                         (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST)
                                               LISPXHIST))   (* ; 
                             "UNDO by smashing with NIL;  makes calls to MARKASCHANGED independent")
                         ]
              NAME])

(FILECOMS
  [LAMBDA (FILE X)                                       (* rmk%: "19-FEB-83 13:55")
    (COND
       ((AND (NULL FILE)
             (NULL X))
        'NILCOMS)
       [(AND (OR (NULL X)
                 (EQ X 'COMS))
             (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE]
       (T (PACK* (NAMEFIELD FILE)
                 (OR X 'COMS])

(WHEREIS
  [LAMBDA (NAME TYPE FILES FN)                        (* ; "Edited 12-Jul-88 17:14 by MASINTER")

    (* ;; "T as a NAME has a special meaning to INFILECOMS?  so don't pass through.")

    (CL:UNLESS (EQ NAME T)
        (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES)
                                           FILELST)
                                      (FUNCTION (LAMBDA (FILE)
                                                  (INFILECOMS? NAME TYPE (FILECOMS FILE]
                               (AND (EQ FILES T)
                                    (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS)
                                    (LET ((FILES NIL))
                                         (for TY inside TYPE
                                            do (for FILE-NAME
                                                      in (XCL::HASH-FILE-WHERE-IS NAME
                                                                    (GETFILEPKGTYPE TYPE))
                                                      do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME))
                                                                    FILES)))
                                         (REVERSE FILES]
             (CL:IF FN
                 [MAPC IN-FILES (FUNCTION (LAMBDA (FILE)
                                            (APPLY* FN NAME FILE]
                 IN-FILES)))])

(SMASHFILECOMS
  [LAMBDA (FILE)                                         (* rmk%: "19-FEB-83 22:15")
    (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X)
       do (SETTOPVAL X 'NOBIND))
    FILE])

(FILEFNSLST
  [LAMBDA (FILE)                                         (* ; "Edited 14-Jun-90 19:30 by jds")
    (FILECOMSLST FILE '(FUNCTIONS FNS])

(FILECOMSLST
  [LAMBDA (FILE TYPE FLG)                                (* JonL "24-Jul-84 19:48")
                                                             (* ; 
                                                    "TYPE is coerced in the innards of INFILECOMS?")
    (COND
       ((EQ FLG 'UPDATE)
        (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE)
                    FLG)))
       (T (INFILECOMS? NIL TYPE (FILECOMS FILE)
                 FLG])

(UPDATEFILES
  [LAMBDA (PRLST FLST)                                   (* rmk%: "19-FEB-83 14:27")

    (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g.  LOAD, LOADFNS) involving the files in FLST began.")

    (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE))
       do (COND
                 ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE)))
                                                             (* ; 
                                                           "FILEPKGCHANGES eliminates duplicates")
                  (/replace CHANGED of TYPE with NIL))
                 (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES
                           (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST
                       first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) 

                             (* ;; "First check NIL=Nowhere.  LST:1 contains variables whose values are on the file literally.  These are `found' but not marked.  LST::1 contains all other items.")

                             (SETQ FOUND (NCONC (CAR LST)
                                                (CDR LST)
                                                FOUND))
                       do (SETQ PCHANGES (COND
                                                ((FMEMB (fetch DATEFILENAME
                                                           of (CAR (fetch FILEDATES
                                                                          of FILE)))
                                                        FLST)

                                 (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began.  Thus, by this intersection we only worry about items that were previously changed;  any items that were only changed during this operation are ignored.")

                                                 (INTERSECTION CHANGED PREVITEMS))
                                                (T CHANGED)))
                             [COND
                                ([AND PCHANGES [SETQ COMS (fetch COMSNAME
                                                             of (SETQ FILEPROP
                                                                     (LISTP (fetch FILEPROP
                                                                               of FILE]
                                      (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE]

                                 (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms")

                                 [COND
                                    ((CDR LST)               (* ; "CDR items must be distributed")
                                     [COND
                                        ((NULL (fetch TOBEDUMPED of FILEPROP))

                                         (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL")

                                         [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL
                                                                                   'NOTLISTEDFILES]
                                         (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE
                                                                              (GETTOPVAL 
                                                                                     '
                                                                                     NOTCOMPILEDFILES
                                                                                     ]
                                                             (* ; 
                                                   "Get the (possibly new) TYPE item list to smash")
                                     [COND
                                        [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED
                                                                        of FILEPROP]
                                        (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE]
                                                             (* ; 
                                                        "Now distribute items to the file property")
                                     (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP)
                                                                                   )
                                        do (/NCONC1 TYPEDPROP Y]
                                 (SETQ FOUND (NCONC (CAR LST)
                                                    (CDR LST)
                                                    FOUND] finally (/replace CHANGED
                                                                          of TYPE
                                                                          with (LDIFFERENCE
                                                                                    CHANGED FOUND])

(INFILECOMS?
  [LAMBDA (NAME TYPE COMS ONFILETYPE)                 (* ; "Edited 12-Jul-88 17:42 by MASINTER")

    (* ;; "Returns T if NAME is 'CONTAINED' in COMS.  If NAME is NIL, then value is a list of all of the functions contained in COMS.  If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.)  Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1.  while elements are the subset of NAME which are on the file in other case")

    (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS?  returns the dotted pair of (literals  . elements) where literals are those which are `literally' on the file (e.g.  (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")

    (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ")

    (PROG (VAL LITERALS ORIGFLG)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (SELECTQ ONFILETYPE
              (EDIT (SELECTQ TYPE
                        (FILEVARS (RETURN))
                        NIL))
              NIL)
          [COND
             ((LITATOM COMS)
              (SELECTQ TYPE
                  ((VARS FILEVARS)                           (* ; 
                                                           "the COMS of a file are also on it")
                       (INFILECOMSVAL COMS))
                  NIL)
              (SETQ COMS (EVALV COMS]
          (INFILECOMS COMS)
          (SETQ VAL (DREVERSE VAL))
          (RETURN (COND
                     ((EQ ONFILETYPE 'UPDATE)
                      (CONS LITERALS VAL))
                     (T VAL])

(INFILECOMTAIL
  [LAMBDA (COM FLG)                                   (* ; "Edited  2-Aug-88 02:15 by masinter")
    [SETQ COM (COND
                 ((EQ (CADR COM)
                      '*)
                  (COND
                     [(LITATOM (CADDR COM))
                      (LISTP (EVALV (CADDR COM]
                     (T [RESETVARS (DWIMLOADFNSFLG)
                                   (NLSETQ (SETQ COM (EVAL (CADDR COM]
                        COM)))
                 (T (CDR COM]
    (if (NOT FLG)
        then (for X in COM
                    do [if (AND (LISTP X)
                                        (EQ (CAR X)
                                            COMMENTFLG))
                               then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X)
                                                                        (OR (NLISTP X)
                                                                            (NEQ (CAR X)
                                                                                 COMMENTFLG]
                    finally (RETURN COM))
      else COM])

(INFILECOMS
  [LAMBDA (COMS)                                         (* rmk%: "19-FEB-83 22:17")
    (for X in COMS do (INFILECOM X])

(INFILECOM
  [LAMBDA (COM)                                       (* ; "Edited  2-Aug-88 02:27 by masinter")
    (COND
       [(NLISTP COM)
        (COND
           ((EQ TYPE 'VARS)
            (INFILECOMSVAL COM]
       ((EQ (CAR COM)
            COMMENTFLG)

        (* ;; 
"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
                                                             (* ; 
  "don't know why I should bother, but someone might want to know all of the comments on a file???")
        (COND
           ((EQ TYPE COMMENTFLG)
            (INFILECOMSVAL COM T)))
        NIL)
       (T
        (PROG ((COMNAME (CAR COM))
               (TAIL (CDR COM))
               CFN TEM)
              (COND
                 [[COND
                     ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
                      (SETQ TEM (APPLY* CFN COM (COND
                                                   ((AND (NULL ONFILETYPE)
                                                         (NOT (CL:SYMBOLP NAME)))
                                                             (* ; 
                                                "call from WHEREIS of a name which is not a symbol")
                                                    (LIST NAME))
                                                   (T NAME))
                                       TYPE ONFILETYPE)))
                     ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
                                                             (* ; "for compatability")
                      (SETQ TEM (APPLY* CFN COM TYPE NAME]
                  (COND
                     [(NLISTP TEM)
                      (COND
                         ((EQ TEM T)
                          (COND
                             ((OR (EQ NAME T)
                                  (NULL ONFILETYPE))
                              (RETFROM 'INFILECOMS? T]
                     (T (INFILECOMSVALS TEM]
                 ((LISTP TAIL)

                  (* ;; "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")

                  (SELECTQ COMNAME
                      ((PROP IFPROP) 
                           (SETQ TAIL (CDR TAIL)))
                      NIL)
                  [COND
                     ((EQ (CAR TAIL)
                          '*)
                      (COND
                         ((LITATOM (CADR TAIL))
                          (SELECTQ TYPE
                              ((VARS FILEVARS) 
                                   (INFILECOMSVAL (CADR TAIL)))
                              NIL))
                         ((AND (LISTP (CADR TAIL))
                               (EQ ONFILETYPE 'UPDATE)
                               (EQ TYPE 'VARS)
                               (EQ (CAADR TAIL)
                                   'PROGN)
                               (FMEMB (CAR (LAST (CADR TAIL)))
                                      NAME))
                          (SETQ VAL (CONS (CADR TAIL)
                                          VAL]
                  (SELECTQ COMNAME
                      ((COMS EXPORT) 
                           (INFILECOMS (INFILECOMTAIL COM T)))
                      (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM)
                                                           T)))
                      (DECLARE%:                             (* ; "skip over DECLARE: tags")
                                 [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM))
                                              (IFCDECLARE (INFILECOMTAIL COM)
                                                     (EQ TYPE 'DECLARE%:])
                      (ORIGINAL                              (* ; "dont expand macros")
                                (PROG ((ORIGFLG T))
                                      (INFILECOMS (INFILECOMTAIL COM T))))
                      ((PROP IFPROP)                         (* ; 
                                       "this currently does not handle `pseudo-types' of PROPNAMES")
                           (SELECTQ TYPE
                               (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM)
                                                              T)
                                             (CADR COM)))
                               (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
                                              (CADR COM)))
                               NIL))
                      (PROPS (RETURN (IFCPROPS COM)))
                      (MACROS (RETURN (SELECTQ TYPE
                                          (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T)
                                                        MACROPROPS))
                                          (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T)))
                                          NIL)))
                      (ALISTS                                (* ; 
                      "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")
                              (RETURN (SELECTQ TYPE
                                          (ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
                                          NIL)))
                      (P [RETURN (SELECTQ TYPE
                                     ((EXPRESSIONS P) 
                                          (INFILECOMSVALS (INFILECOMTAIL COM T)
                                                 T))
                                     (COND
                                        ((NULL ONFILETYPE)   (* ; "for WHEREIS and FILECOMSLST")
                                         (SELECTQ TYPE
                                             (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR))
                                             (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE))
                                             NIL])
                      ((ADDVARS APPENDVARS) 
                           (SELECTQ TYPE
                               (VARS [RETURN (AND (NULL ONFILETYPE)
                                                  (for X in (INFILECOMTAIL COM T)
                                                     do (INFILECOMSVAL (CAR X)
                                                                   T])
                               (ALISTS [RETURN (for X in (INFILECOMTAIL COM T)
                                                  when (EQMEMB 'ALIST (GETPROP (CAR X)
                                                                                 'VARTYPE))
                                                  do (for Z in (CDR X)
                                                            do (INFILECOMSVAL
                                                                    (LIST (CAR X)
                                                                          (CAR Z))
                                                                    T])
                               (OR (EQ TYPE COMNAME)
                                   (RETURN))))
                      ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) 
                           [RETURN (COND
                                      ((EQ TYPE 'EXPRESSIONS)
                                       (for X in (INFILECOMTAIL COM T)
                                          when (AND (LISTP X)
                                                        (NEQ (CAR X)
                                                             COMMENTFLG))
                                          do (INFILECOMSVAL (CONS 'SETQ X)
                                                        T)))
                                      ((OR (EQ TYPE 'VARS)
                                           (EQ TYPE COMNAME))(* ; 
                   "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
                                       (for X in (INFILECOMTAIL COM T)
                                          do (COND
                                                    ((LISTP X)
                                                     (AND (CAR X)
                                                          (NEQ (CAR X)
                                                               COMMENTFLG)
                                                          (INFILECOMSVAL (CAR X)
                                                                 T)))
                                                    (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS])
                      (DEFS [RETURN (for X in (INFILECOMTAIL COM T)
                                       when (EQ TYPE (CAR X)) do (INFILECOMSVALS
                                                                          (CDR X])
                      (FILES (RETURN))
                      NIL)

                  (* ;; "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")

                  (COND
                     ((EQ COMNAME TYPE)
                      (INFILECOMSVALS (INFILECOMTAIL COM T)))
                     [(AND (LISTP TYPE)
                           (FMEMB COMNAME TYPE))
                      (LET ((TYPE COMNAME))
                           (INFILECOMSVALS (INFILECOMTAIL COM T]
                     ((AND (OR (NULL CFN)
                               (AND (EQ CFN T)
                                    (NULL ONFILETYPE)))
                           (NULL ORIGFLG)
                           (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
                      (INFILECOMS (SUBPAIR (CAR TEM)
                                             (INFILECOMTAIL COM T)
                                             (CDR TEM])

(INFILECOMSVALS
  [LAMBDA (X FLG)                                     (* ; "Edited  2-Aug-88 02:21 by masinter")
    (for Y in X when (NOT (AND (LISTP Y)
                                           (EQ (CAR Y)
                                               COMMENTFLG))) do (INFILECOMSVAL Y FLG])

(INFILECOMSVAL
  [LAMBDA (X FLG)                                     (* ; "Edited 12-Jul-88 17:56 by MASINTER")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND (OR (NULL NAME)
                 (MEMBER X NAME))
             (COND
                (FLG (SETQ LITERALS (CONS X LITERALS)))
                (T (SETQ VAL (CONS X VAL]
       ((AND (EQ ONFILETYPE 'EDIT)
             FLG)                                            (* ; 
                                        "literals should not be edited as they are on the fileCOMS")
        NIL)
       ((EQ ONFILETYPE 'TYPESOF)
        (AND (COND
                ((LITATOM NAME)
                 (EQ NAME X))
                (T (EQUAL NAME X)))
             (CL:PUSHNEW TYPE VAL)))
       ([OR (EQ NAME T)
            (COND
               ((LITATOM NAME)
                (EQ NAME X))
               (T (EQUAL NAME X]
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS X VAL])

(INFILECOMSPROP
  [LAMBDA (AT PROP)                                      (* lmm "25-SEP-81 17:15")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND [OR (NULL NAME)
                 (find X in NAME suchthat (AND (EQ (CAR X)
                                                               AT)
                                                           (EQ (CADR X)
                                                               PROP]
             (SETQ VAL (CONS (LIST AT PROP)
                             VAL]
       ((OR (EQ NAME T)
            (AND (EQ (CAR NAME)
                     AT)
                 (EQ (CADR NAME)
                     PROP)))
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS (LIST AT PROP)
                        VAL])

(IFCPROPS
  [LAMBDA (COM)                                          (* bvm%: " 2-Dec-83 14:24")

(* ;;; "Examine a PROPS com for objects of specified TYPE")

    (SELECTQ TYPE
        (PROPS                                               (* ; 
                                       "the PROPS command can actually take (PROPNAME at1 at2 ...)")
               (INFILEPAIRS (INFILECOMTAIL COM)))
        (PROP                                                (* ; 
                                                "return the atoms which have any properties at all")
              (for PAIR in (INFILECOMTAIL COM) do (for ATNAME
                                                                     inside (CAR PAIR)
                                                                     do (INFILECOMSVAL ATNAME
                                                                                   ))))
        (MACROS                                              (* ; "only MACRO properties")
                (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR)
                                                                           (CDR PAIR))))
        NIL])

(IFCEXPRTYPE
  [LAMBDA (COM FN)                                       (* ; "Edited  6-Apr-87 20:20 by Pavel")

(* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN")

    (for SUBCOM in (INFILECOMTAIL COM)
       when (AND (EQ (CAR SUBCOM)
                         FN)
                     (EQ (CAR (LISTP (CADR SUBCOM)))
                         'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM))
                                                T])

(IFCPROPSCAN
  [LAMBDA (ATOMS PROPNAMES)                           (* ; "Edited  2-Aug-88 02:20 by masinter")

(* ;;; 
"Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES")

    (for AT in ATOMS WHEN (LITATOM AT) unless [COND
                                                                 [(EQ ONFILETYPE 'UPDATE)
                                                                  (COND
                                                                     (NAME (NOT (ASSOC AT NAME]
                                                                 ((LISTP NAME)
                                                                  (NEQ AT (CAR NAME]
       do (COND
                 ((EQ PROPNAMES 'ALL)
                  (for PROP in (GETPROPLIST AT) by (CDDR PROP)
                     when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP)))
                 (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])

(IFCDECLARE
  [LAMBDA (TAIL WANTDECLARE)                          (* ; "Edited  8-Jun-90 18:11 by teruuchi")
    (PROG ((TAIL TAIL))
      LP  (COND
             ((LISTP TAIL)
              [SELECTQ (CAR TAIL)
                  ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                       [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
                                                                 (CADR TAIL]
                       (SETQ TAIL (CDR TAIL)))
                  (DONTEVAL@LOAD [COND
                                    ((OR (\STKSCAN 'DOFILESLOAD)
                                         (\STKSCAN 'LOAD))
                                                  (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"")
                                     (RETURN))
                                    (WANTDECLARE (INFILECOMSVAL (CAR TAIL])
                  (COMPILERVARS (RETURN))
                  (COND
                     [(FMEMB (CAR TAIL)
                             DECLARETAGSLST)
                      (COND
                         (WANTDECLARE (INFILECOMSVAL (CAR TAIL]
                     (T (INFILECOM (CAR TAIL]
              (SETQ TAIL (CDR TAIL))
              (GO LP])

(INFILEPAIRS
  [LAMBDA (LST)                                          (* lmm " 4-DEC-78 09:51")
    (for LL in LST do (for X inside (CAR LL)
                                     do (for Y inside (CDR LL)
                                               do (INFILECOMSVAL (LIST X Y])

(INFILECOMSMACRO
  [LAMBDA (ATS PROPS)                                    (* lmm "28-SEP-78 18:35")

    (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.  --- Normally (e.g.  for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom.  However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties")

    (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE)
                                               (EVERY (PROPNAMES AT)
                                                      (FUNCTION (LAMBDA (X)
                                                                  (OR (NOT (FMEMB X MACROPROPS))
                                                                      (EQMEMB X PROPS]
                                           [SOME MACROPROPS (FUNCTION (LAMBDA (PROP)
                                                                        (EQMEMB PROP PROPS]
                                           (INFILECOMSVAL AT])
)



(* ;; "adding to a file")

(DEFINEQ

(FILES?
  [LAMBDA NIL                                            (* bvm%: "27-Oct-86 18:14")

(* ;;; 
"Display each file needing dumping, etc.  For files needing dumping, display details of why.")

    (UPDATEFILES)
    (LET (FILES CHANGES PRINTED)
         (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED
                                                                of (LISTP (fetch FILEPROP
                                                                                 of FILE]
            do (if (NOT PRINTED)
                       then (LISPXPRIN1 "To be dumped:
" T)
                             (SETQ PRINTED T))
                  (LISPXPRIN2 FILE T)
                  (LISPXPRIN1 " ...changes to " T)
                  [for CH in CHANGES bind TB
                     do (COND
                               ((LISTP CH)
                                [COND
                                   (TB (LISPXTAB TB NIL T))
                                   (T (SETQ TB (POSITION T]
                                (LISPXPRIN2 (CAR CH)
                                       T)
                                (FILES?PRINTLST (CDR CH)))
                               (T                            (* ; "old style")
                                  (LISPXPRIN2 CH T)
                                  (LISPXSPACES 1 T]
                  (LISPXTERPRI T))
         (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED "    plus "))
            do (SETQ FLG T) finally (if FLG
                                                then (OR PRINTED (LISPXPRIN1 "...to be dumped.  "
                                                                            T))
                                                      (ADDTOFILES?)))
         (if (SETQ FILES NOTCOMPILEDFILES)
             then (FILES?PRINTLST FILES "To be compiled: ")
                   (LISPXTERPRI T))
         (if (SETQ FILES NOTLISTEDFILES)
             then (FILES?PRINTLST FILES "To be listed: ")
                   (LISPXTERPRI T))
         (CL:VALUES])

(FILES?1
  [LAMBDA (TYPE FIRST)                                   (* bvm%: "27-Oct-86 18:17")

    (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.")

    (LET (STR LST)
         (COND
            ([AND (LITATOM TYPE)
                  (SETQ STR (fetch DESCRIPTION of TYPE))
                  (LISTP (SETQ LST (fetch CHANGED of TYPE]
             (AND FIRST (LISPXPRIN1 FIRST T))
             (LISPXPRIN1 '"the " T)
             (LISPXPRIN1 STR T)
             (FILES?PRINTLST LST)
             (LISPXTERPRI T)
             T])

(FILES?PRINTLST
  [LAMBDA (LST STR)                                      (* bvm%: "27-Oct-86 18:15")

    (* ;; "Print elements of LST separated by commas and indenting new lines a bunch.  If MAPRINT had a left margin arg, this would be simpler.")

    (MAPRINT LST T (OR STR ": ")
           NIL ", " [FUNCTION (LAMBDA (STR)
                                (COND
                                   ((> (+ (POSITION T)
                                          (NCHARS STR T T)
                                          3)
                                       (LINELENGTH NIL T))
                                    (LISPXTERPRI T)
                                    (LISPXPRIN1 "         " T)))
                                (LISPXPRIN2 STR T T]
           T])

(ADDTOFILES?
  [LAMBDA (NOASKSTR)                                    (* ; "Edited 10-Aug-2020 21:18 by rmk:")
                                                             (* ; "Edited 21-Aug-91 10:13 by jds")

    (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says")

    (* ;; "RMK: Eliminated literal CR's in the key list.")

    (ERSETQ
     (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS]

      (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g.  changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES")

           [COND
              (NOASKSTR (PRIN1 NOASKSTR T))
              (T (DOBE)
                 (SETQ BUFS (READP T))
                 (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go")
                                 `([Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL]
                                   [N ,(CONCAT "o" (CHARACTER (CHARCODE EOL]
                                   (%] ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
                                       EXPLAINSTRING 
                                       "] - nowhere, all items will be marked as dummy
" NOECHOFLG T))
                                 T)
                     (N (RETURN))
                     (%]                                     (* ; "Nowhere")
                         (for TYPE in FILEPKGTYPES
                            do (for NAME in (fetch (FILEPKGTYPE CHANGED)
                                                           of TYPE)
                                      do (ADDTOFILE NAME TYPE NIL)))
                         (RETURN))
                     NIL)                                    (* ; 
                              "if there was type-ahead BEFORE the askuser, then don't allow it now")
                 (COND
                    (BUFS (SETQ BUFS (COND
                                        ((READP T)
                                         (LINBUF)
                                         (SYSBUF)
                                         (SETQ BUFS (CLBUFS NIL T READBUF]
           [for TYPE STR LST in FILEPKGTYPES
              when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
                            (LISTP (SETQ LST (COND
                                                ((EQ TYPE 'VARS)
                                                 VARSCHANGES)
                                                (T (fetch (FILEPKGTYPE CHANGED) of TYPE]
              do
              (printout T "(" STR ")" T)
              (for NAME TEM FILE in LST when NAME
                 do
                 (PROG NIL
                   LP  (PRIN2 NAME T)
                       (SPACES 2 T)

                  (* ;; "if user typed ahead before entering addtofiles??  then dont allow typeahead here, because it will justgobble his earlier typeahead.")

                  (* ;; "SELCHARQ to avoid literal CR")

                       (SELCHARQ (CHCON1 (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T)))
                            (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)

                                 (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer")

                                               (DOBE)))
                                (GO LP))
                            (%]                              (* ; "Nowhere")
                                (SETQ FILE))
                            (SPACE                           (* ; "No action")
                                   (RETURN))
                            ((LF =) 
                                 (PRINT (OR (SETQ FILE LASTFILE)
                                            'Nowhere)
                                        T))
                            (SETQ FILE TEM))
                       (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
                                         (SETQ PLACE (WHATIS FILE NIL TYPE))
                                         [COND
                                            ((LITATOM PLACE) (* ; "file name")
                                             (SETQ FILE PLACE)
                                             (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                                                        NAME TYPE NEAR LISTNAME)
                                                 (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                          (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.")

                                             )
                                            ((EQ (CAR PLACE)
                                                 'Near%:)
                                             (SETQ NEAR (CADR PLACE))
                                             (COND
                                                ([SOME FILELST (FUNCTION (LAMBDA (FL)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           FL))
                                                                            NAME TYPE NEAR LISTNAME]
                                                 (PRINT (LIST 'on FILE)
                                                        T T))
                                                (T (PRINT (LIST (CADR PLACE)
                                                                'not
                                                                'found)
                                                          T T)
                                                   (ERROR!)))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE)))
                                            ([OR [UNDONLSETQ (PROGN (SAVESET
                                                                     (SETQ LISTNAME (CAR PLACE))
                                                                     (MERGEINSERT
                                                                      NAME
                                                                      (LISTP (GETTOPVAL LISTNAME))
                                                                      T)
                                                                     T
                                                                     'NOPRINT)
                                                                    (OR (SETQ FILE
                                                                         (CAR (WHEREIS NAME TYPE
                                                                                     FILELST)))
                                                                        (ERROR!]
                                                 (SOME FILELST (FUNCTION (LAMBDA (X)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           X))
                                                                            NAME TYPE NEAR LISTNAME]
                                             (PRIN1 "  value is filed on " T)
                                             (PRINT FILE T T)
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                 (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed")

                                             )
                                            (T (PRIN1 "    put list " T)
                                               (PRIN2 (CAR PLACE)
                                                      T T)
                                               (SETQ FILE
                                                (WHATIS (ASKUSER NIL NIL " on file: "
                                                                   '(("" "" EXPLAINSTRING 
                                                                         "a file name" KEYLST ()))
                                                                   T)
                                                       'FILE))
                                               (SAVESET (CAR PLACE)
                                                      (MERGEINSERT NAME
                                                             (LISTP (GETTOPVAL (CAR PLACE)))
                                                             T)
                                                      T
                                                      'NOPRINT)

                                     (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.")

                                               (ADDNEWCOM (FILECOMS FILE)
                                                      NAME TYPE (CAR PLACE)
                                                      FILE)
                                               (for F in (fetch WHENFILED of TYPE)
                                                  do (for I in (GETTOPVAL (CAR PLACE))
                                                            do (APPLY* F I TYPE FILE]
                                         (AND FILE (ADDFILE FILE))
                                         (SETQ LASTFILE PLACE)))
                           (GO LP]
           (AND BUFS (BKBUFS BUFS))
           (UPDATEFILES])

(ADDTOFILE
  [LAMBDA (NAME TYPE FILE NEAR LISTNAME)                 (* lmm "21-Nov-84 11:43")
                                                             (* ; "adds NAME to the file FILE")
    (PROG (TEM COMSNAME)
          [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T)
                         (COND
                            ((FMEMB TYPE FILELST)
                             (GETFILEPKGTYPE (swap TYPE FILE)))
                            (T (GETFILEPKGTYPE TYPE]
          (SETQ FILE (WHATIS FILE 'FILE))
          (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                     NAME TYPE NEAR LISTNAME)
              (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
          (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))
          (AND FILE (NOT (FMEMB FILE FILELST))
               (ADDFILE FILE))
          (RETURN FILE])

(WHATIS
  [LAMBDA (USERINPUT ONLY)                               (* lmm "28-Nov-84 16:49")

    (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble;  if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable")

    (PROG (TEM UCASE)
          (RETURN (COND
                     ((NULL USERINPUT)                       (* ; "nowhere")
                      NIL)
                     [(LISTP USERINPUT)
                      (COND
                         (ONLY (ERROR!))
                         (T (SELECTQ (CAR USERINPUT)
                                ((@ Near%:) 
                                     (CONS 'Near%: (CDR USERINPUT)))
                                (WHATIS (CAR USERINPUT)
                                       'LIST]
                     ([AND (NEQ ONLY 'LIST)
                           (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT)))
                                      FILELST)
                               (LISTP (GETTOPVAL (FILECOMS UCASE)))
                               (SETQ TEM (FIXSPELL UCASE NIL FILELST T]
                      TEM)
                     ((AND (NEQ ONLY 'FILE)
                           (LISTP (GETTOPVAL USERINPUT)))
                      (LIST USERINPUT))
                     ((AND (NEQ ONLY 'LIST)
                           (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE)
                                      NIL T)
                               'Y))
                      UCASE)
                     ((AND (NEQ ONLY 'FILE)
                           (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT)
                                      NIL T)
                               'Y))
                      (LIST USERINPUT))
                     (T                                      (* ; "none of above")
                        (ERROR!])

(ADDTOCOMS
  [LAMBDA (COMS NAME TYPE NEAR LISTNAME)                 (* rmk%: "10-JUN-82 22:53")

    (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms);  return NIL if unsuccessful.  If LISTNAME is given, then only insert by adding to LISTNAME.  If NEAR is given, only insert near it")

    (COND
       ((NULL COMS)
        NIL)
       [(LITATOM COMS)                                       (* ; 
      "given a name of a command;  rebind COMSNAME to current variable and try to add to its value")
        (OR [PROG ((COMSNAME COMS))
                  (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME))
                                 NAME TYPE NEAR (AND (NEQ COMS LISTNAME)
                                                     LISTNAME]
            (AND (EQ COMS LISTNAME)
                 (ADDNEWCOM COMS NAME TYPE]
       (T (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (for TAIL on COMS do (COND
                                              [(LISTP (CAR TAIL))
                                               (COND
                                                  ((ADDTOCOM (CAR TAIL)
                                                          NAME TYPE NEAR LISTNAME)
                                                   (RETURN T]
                                              (T (SELECTQ (CAR TAIL)
                                                     ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                                                          (SETQ TAIL (CDR TAIL)))
                                                     NIL])

(ADDTOCOM
  [LAMBDA (COM NAME TYPE NEAR LISTNAME)                  (* ; "Edited  2-May-87 19:04 by Pavel")
                                                             (* ; 
                        "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful")
    (PROG (TEM)
          (COND
             ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM]
              (RETURN)))
          [COND
             ((SETQ TEM (fetch ADD of (CAR COM)))
              (RETURN (COND
                         ((OR (NULL LISTNAME)
                              (INFILECOMS? LISTNAME 'FILEVARS (LIST COM)))
                          (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR))
                               (MARKASCHANGED COMSNAME 'VARS))
                          TEM]
          (RETURN
           (SELECTQ (CAR COM)
               (FNS (AND (EQ TYPE 'FNS)
                         (ADDTOCOM1 COM NAME NEAR LISTNAME)))
               ((VARS INITVARS) 
                    (COND
                       ((OR (EQ (CAR COM)
                                'VARS)
                            NEAR LISTNAME)                   (* ; 
                                  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.")
                        (SELECTQ TYPE
                            (EXPRESSIONS (COND
                                            ((EQ (CAR NAME)
                                                 'SETQ)
                                             (ADDTOCOM1 COM (CDR NAME)
                                                    NEAR LISTNAME))))
                            (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME))
                            NIL))))
               (COMS (ADDTOCOMS (COND
                                       [(EQ (CADR COM)
                                            '*)
                                        (COND
                                           ((LITATOM (CADDR COM))
                                            (CADDR COM))
                                           (T (RETURN]
                                       (T (CDR COM)))
                            NAME TYPE NEAR LISTNAME))
               (DECLARE%: (AND (OR LISTNAME NEAR)
                               (ADDTOCOMS (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     ((LITATOM (CADDR COM))
                                                      (CADDR COM))
                                                     (T (RETURN]
                                                 (T (CDR COM)))
                                      NAME TYPE NEAR LISTNAME)))
               (CL:EVAL-WHEN (AND (OR LISTNAME NEAR)
                                  (ADDTOCOMS (COND
                                                    [(EQ (CL:THIRD COM)
                                                         '*)
                                                     (COND
                                                        ((LITATOM (CL:FOURTH COM))
                                                         (CL:FOURTH COM))
                                                        (T (RETURN]
                                                    (T (CDDR COM)))
                                         NAME TYPE NEAR LISTNAME)))
               ((PROP IFPROP) 
                    (SELECTQ TYPE
                        (PROPS (COND
                                  ((EQ (CADR COM)
                                       (CADR NAME))
                                   (ADDTOCOM1 (CDR COM)
                                          (CAR NAME)
                                          NEAR LISTNAME))
                                  ((AND (EQ (CAR NAME)
                                            (CADDR COM))
                                        (NULL (CDDDR COM)))
                                   [/RPLACA (CDR COM)
                                          (UNION (MKLIST (CDR NAME))
                                                 (MKLIST (CADR COM]
                                   (MARKASCHANGED COMSNAME 'VARS)
                                   T)))
                        (MACROS (COND
                                   ([AND (for PROP inside (CADR COM)
                                            always (EQMEMB PROP MACROPROPS))
                                         (for PROP in MACROPROPS
                                            always (OR (EQMEMB PROP (CADR COM))
                                                           (NOT (GETPROP NAME PROP]

                                    (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")

                                    (ADDTOCOM1 (CDR COM)
                                           NAME NEAR LISTNAME))))
                        NIL))
               ((PROPS ALISTS) 
                    (AND (EQ TYPE (CAR COM))
                         (ADDTOCOM1
                          COM
                          (/NCONC1 (OR [ASSOC (CAR NAME)
                                              (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     [(LITATOM (CADDR COM))
                                                      (AND (OR (NULL LISTNAME)
                                                               (EQ (CADDR COM)
                                                                   LISTNAME))
                                                           (GETTOPVAL (CADDR COM]
                                                     (T (RETURN]
                                                 (T (CDR COM]
                                       (LIST (CAR NAME)))
                                 (CADR NAME))
                          NEAR LISTNAME)))
               (P (COND
                     ((AND (EQ TYPE 'EXPRESSIONS)
                           (NEQ (CAR NAME)
                                'SETQ))
                      (ADDTOCOM1 COM NAME NEAR LISTNAME))))
               (AND (EQ (CAR COM)
                        TYPE)
                    (ADDTOCOM1 COM NAME NEAR LISTNAME])

(ADDTOCOM1
  [LAMBDA (COM NAME NEAR LISTNAME)                       (* rmk%: " 3-JAN-82 22:53")
    (COND
       [(EQ (CADR COM)
            '*)                                              (* ; "add to list name")
        (AND [COND
                (LISTNAME (EQ (CADDR COM)
                              LISTNAME))
                (T (LITATOM (CADDR COM]
             (SAVESET (CADDR COM)
                    [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM]
                           (COND
                              ((AND NEAR (SETQ NEAR (MEMBER NEAR COM)))
                               (/RPLACD NEAR (CONS NAME (CDR NEAR)))
                               COM)
                              (T (MERGEINSERT NAME COM T]
                    T
                    'NOPRINT]
       ((NULL LISTNAME)                                      (* ; "add to standard com")
        [AND (NOT (MEMBER NAME (CDR COM)))
             (COND
                [(SETQ NEAR (MEMBER NEAR COM))
                 (/RPLACD NEAR (CONS NAME (CDR NEAR]
                (T (/RPLACD COM (MERGEINSERT NAME (CDR COM]
        (MARKASCHANGED COMSNAME 'VARS)
        T])

(ADDNEWCOM
  [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE)             (* rmk%: " 3-JAN-82 22:53")

    (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE.  --- if LISTNAME is given, then use it as the listname")

    (PROG (NEWCOM OLDCOM TAIL)
          (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE))
          [COND
             ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME)))
              (RETURN (SAVESET COMSNAME (LIST NEWCOM)
                             T
                             'NOPRINT]
      LP  [COND
             ((OR (NLISTP (SETQ OLDCOM (CAR TAIL)))
                  (SELECTQ (CAR OLDCOM)
                      ((LOCALVARS SPECVARS BLOCKS) 
                           T)
                      (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM)))
                      NIL))
              (/ATTACH NEWCOM TAIL))
             ((LISTP (CDR TAIL))
              (SETQ TAIL (CDR TAIL))
              (GO LP))
             (T (/RPLACD TAIL (LIST NEWCOM]
          (MARKASCHANGED COMSNAME 'VARS])

(MAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* ; "Edited  8-Apr-87 14:55 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    (PROG (TEM)

     (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname")

          (AND (LISTP NAME)
               (SETQ NAME (COPY NAME)))
          (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE))
                           (APPLY* TEM NAME TYPE LISTNAME FILE))
                      (SELECTQ TYPE
                          (PROPS [AND (NULL LISTNAME)
                                      (CONS 'PROP (CONS (COND
                                                           ((AND (LISTP (CDR NAME))
                                                                 (NULL (CDDR NAME)))
                                                            (CADR NAME))
                                                           (T (CDR NAME)))
                                                        (OR (LISTP (CAR NAME))
                                                            (LIST (CAR NAME])
                          (EXPRESSIONS [COND
                                          ((EQ (CAR NAME)
                                               'SETQ)
                                           (MAKENEWCOM (CDR NAME)
                                                  'VARS LISTNAME FILE))
                                          (T (CONS 'P (COND
                                                         (LISTNAME (LIST '* LISTNAME))
                                                         (T (LIST NAME])
                          NIL)
                      (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE])

(DEFAULTMAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* lmm "20-OCT-82 22:48")
    (COND
       ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST)
                 (fetch MACRO of TYPE)
                 (fetch GETDEF of TYPE)))
        (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION
                                                                            of TYPE)
                                                                         TYPE)
               T))
       ((NULL DEFAULTCOMHASFILEFLG)                          (* ; "disable FOOFNS FOOVARS junk")
        (LIST TYPE NAME))
       ((EQ FILE T)                                          (* ; 
                                                           "FILE=T only when called from SHOWDEF")
        (LIST TYPE NAME))
       ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE))
                                      (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME))
                                             T)
                                      T
                                      'NOPRINT]              (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items")
        (LIST TYPE '* LISTNAME))
       (T (LIST TYPE NAME])
)

(RPAQ? DEFAULTCOMHASFILEFLG )

(ADDTOVAR MARKASCHANGEDFNS )
(DEFINEQ

(MERGEINSERT
  [LAMBDA (NEW LST ONEFLG)                               (* lmm "30-Jun-86 18:11")

    (* ;; "searches LST to find the most reasonable place to insert NEW.  Does nothing if ONEFLG is T and NEW is already a member of LST")

    (COND
       ((AND ONEFLG (MEMBER NEW LST))
        LST)
       ((LISTP NEW)
        (/NCONC1 LST NEW))
       (T (PROG ((N 0)
                 LST1 PLACE TEM)
                (SETQ LST1 LST)
            LP  

           (* ;; "finds the function with the longest leading common substring.  The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.")

                (COND
                   ((NULL LST1)
                    (GO OUT))
                   ((OR (LISTP (CAR LST1))
                        (SETQ TEM (STRPOS (CAR LST1)
                                         NEW 1 NIL T T)))

                    (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE")

                    (SETQ PLACE LST1)
                    (GO OUT))
                   ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1)
                                                NEW))
                           N)
                    (SETQ N TEM)
                    (SETQ PLACE LST1)))
                (SETQ LST1 (CDR LST1))
                (GO LP)
            OUT (SETQ TEM (CAR PLACE))
                (OR [SOME (OR PLACE LST)
                          (FUNCTION (LAMBDA (X LST)
                                      (COND
                                         ([OR (ALPHORDER NEW X)
                                              (AND PLACE (NOT (ALPHORDER TEM X]

                                 (* ;; "for example, if the FNS list is something like (...  FOO FOO1 ...) where the ...  may or may not be in order, e.g.  (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.")

                                          (/ATTACH NEW LST))
                                         (T (SETQ TEM X)
                                            NIL]
                    (SETQ LST (/NCONC1 LST NEW)))
                (RETURN LST])

(MERGEINSERT1
  [LAMBDA (X Y)                                          (* rmk%: "24-MAY-82 00:05")

    (* ;; "value is the number of leading characters of X and Y that agree.")

    (PROG ((N 1)
           C1 C2)
      LP  [COND
             ((OR (NULL (SETQ C1 (NTHCHARCODE X N)))
                  (NULL (SETQ C2 (NTHCHARCODE Y N)))
                  (NEQ C1 C2))
              (RETURN (SUB1 N]
          (SETQ N (ADD1 N))
          (GO LP])
)



(* ;; 
"RMK: Changed INITVARS to VARS, so = addition is a synonym for untypable LF, and also suppress appearance of raw CR and LF in the file"
)


(RPAQ ADDTOFILEKEYLST
      `(("[" "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" NOECHOFLG T)
        (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T)
        (,(CHARACTER (CHARCODE LF))
         "" EXPLAINSTRING "{line-feed} - same as previous response" NOECHOFLG T)
        (" " ,(CONCATCODES (LIST (CHARCODE SPACE)
                                 (CHARCODE EOL)))
             EXPLAINSTRING "{space} - no action" NOECHOFLG T)
        ("]" ,(CONCAT "Nowhere" (CHARACTER (CHARCODE EOL)))
             EXPLAINSTRING
             ,(CONCAT "] - nowhere, item is marked as a dummy" (CHARACTER (CHARCODE EOL)))
             NOECHOFLG T)
        ["(" "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
             (( "" CONFIRMFG [%) %] ,(CHARACTER (CHARCODE SPACE))
                                  ,(CHARACTER (CHARCODE EOL]
                 RETURN
                 (CDR ANSWER]
        (@ "Near: " EXPLAINSTRING "@ other-item   -- put the item near the other item" NOECHOFLG T 
           KEYLST (( "" CONFIRMFLG [,(CHARACTER (CHARCODE EOL]
                      RETURN ANSWER)))
        [,(CHARACTER (CHARCODE CR))
         "" RETURN ,(CHARACTER (CHARCODE SPACE]
        ("" "File name: " EXPLAINSTRING "a file name" KEYLST ())))

(RPAQQ LASTFILE NIL)



(* ;; "deleting an item from a file")

(DEFINEQ

(DELFROMFILES
  [LAMBDA (NAME TYPE FILES)                              (* rmk%: " 6-MAR-82 13:16")

    (* ;; "Eliminates NAME as an item of type TYPE in COMS.")

    (PROG (COMS)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (RETURN (for FILE inside (OR FILES FILELST)
                     when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE))
                                            NAME TYPE)
                                  (COND
                                     ((INFILECOMS? NAME TYPE COMS)
                                      (printout T "(could not delete " NAME " from " FILE ")" T))))
                     collect (for FN in (fetch WHENUNFILED of TYPE)
                                    do (APPLY* FN NAME TYPE FILE))
                           FILE])

(DELFROMCOMS
  [LAMBDA (COMS NAME TYPE)                               (* bvm%: " 1-Oct-86 22:02")

    (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list).  Returns T if it does anything")

    (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.")

    (COND
       [(LITATOM COMS)
        (LET ((COMSNAME COMS))
             (DECLARE (SPECVARS COMS))
             (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME)))
                  (DELFROMCOMS COMS NAME TYPE]
       (T (PROG (DONE)
                (SETQ TYPE (GETFILEPKGTYPE TYPE))
            LP  (COND
                   ((NLISTP COMS)
                    (RETURN DONE)))
                [COND
                   ((LISTP (CAR COMS))
                    (SELECTQ (DELFROMCOM (CAR COMS)
                                    NAME TYPE)
                        (ALL (/RPLNODE2 COMS (CDR COMS))
                             (SETQQ DONE ALL)
                             (GO LP))
                        (NIL)
                        (SETQ DONE T)))
                   (T (SELECTQ (CAR COMS)
                          ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                               (SETQ COMS (CDR COMS)))
                          (COND
                             ((AND (EQ TYPE 'VARS)
                                   (EQ NAME (CAR COMS)))
                              (/RPLNODE2 COMS (CDR COMS))
                              (SETQ DONE T)
                              (GO LP]
                (SETQ COMS (CDR COMS))
                (GO LP])

(DELFROMCOM
  [LAMBDA (COM NAME TYPE)                                (* ; "Edited  2-May-87 19:02 by Pavel")
                                                             (* ; "Tries to delete NAME from COM")
    (PROG (TEM VAR NEW)
          (COND
             ((SETQ TEM (fetch DELETE of (CAR COM)))
              (AND (SETQ TEM (APPLY* TEM COM NAME TYPE))
                   (MARKASCHANGED COMSNAME 'VARS))
              (RETURN TEM)))
          (RETURN (SELECTQ (CAR COM)
                      ((DECLARE%: COMS) 
                           (DELFROMCOMS (COND
                                               [(EQ (CADR COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CADDR COM))
                                                    (CADDR COM))
                                                   (T (RETURN]
                                               (T (CDR COM)))
                                  NAME TYPE))
                      ((CL:EVAL-WHEN) 
                           (DELFROMCOMS (COND
                                               [(EQ (CL:THIRD COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CL:FOURTH COM))
                                                    (CL:FOURTH COM))
                                                   (T (RETURN]
                                               (T (CDDR COM)))
                                  NAME TYPE))
                      ((ALISTS PROPS) 
                           (AND (EQ TYPE (CAR COM))
                                (COND
                                   ((EQ (CADR COM)
                                        '*)
                                    (COND
                                       ([AND (LITATOM (SETQ VAR (CADDR COM)))
                                             (SETQ TEM (ASSOC (CAR NAME)
                                                              (GETTOPVAL VAR)))
                                             (NEQ (CDR TEM)
                                                  (SETQ TEM (REMOVEITEM (CADR NAME)
                                                                   (CDR TEM]
                                        (SAVESET VAR TEM T 'NOPRINT)
                                        T)))
                                   ([AND [CDR (SETQ TEM (ASSOC (CAR NAME)
                                                               (CDR COM]
                                         (NEQ (CDR TEM)
                                              (SETQ NEW (REMOVEITEM (CADR NAME)
                                                               (CDR TEM]
                                    (/RPLACD TEM NEW)
                                    (MARKASCHANGED COMSNAME 'VARS)
                                    T))))
                      (BLOCKS 
                              (* ;; "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")

                              [AND (EQ TYPE 'FNS)
                                   (for BLOCK in (INFILECOMTAIL COM T)
                                      do (AND (MEMB NAME BLOCK)
                                                  (/DREMOVE NAME BLOCK))
                                            (for X in BLOCK
                                               when (AND (LISTP X)
                                                             (MEMB NAME (CDR X)))
                                               do (/RPLACD X (REMOVE NAME (CDR X])
                      ((PROP IFPROP) 
                           [SELECTQ TYPE
                               (PROPS (RETURN (COND
                                                 ((EQ (CADR COM)
                                                      (CADR NAME))
                                                  (DELFROMCOM1 (CDR COM)
                                                         (CAR NAME)))
                                                 ((AND (EQMEMB (CADR NAME)
                                                              (CADR COM))
                                                       [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM]
                                                       (EQ (CAR TEM)
                                                           (CAR NAME)))
                                                  [/RPLACA (CDR COM)
                                                         (REMOVE (CADR NAME)
                                                                (MKLIST (CADR COM]
                                                  (MARKASCHANGED COMSNAME 'VARS)
                                                  T))))
                               (COND
                                  ([for PROP inside (CADR COM)
                                      always (EQ TYPE (GETPROP PROP 'PROPTYPE]
                                   (DELFROMCOM1 (CDR COM)
                                          NAME])
                      ((RECORDS INITRECORDS SYSRECORDS) 
                           (AND (EQ TYPE 'RECORDS)
                                (DELFROMCOM1 COM NAME)))
                      (P (AND (EQ TYPE 'EXPRESSIONS)
                              (DELFROMCOM1 COM NAME)))
                      ((VARS INITVARS) 
                           (AND (EQ TYPE 'VARS)
                                (DELFROMCOM1 COM NAME T)))
                      (AND (EQ TYPE (CAR COM))
                           (DELFROMCOM1 COM NAME])

(DELFROMCOM1
  [LAMBDA (COM NAME FLG)                                 (* rmk%: "10-JUN-82 22:44")

    (* ;; 
  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed")

    (LET (TEM VAL)
         (COND
            ((EQ (CADR COM)
                 '*)
             (COND
                ([AND (LITATOM (SETQ TEM (CADDR COM)))
                      (NEQ (SETQ VAL (GETTOPVAL TEM))
                           (SETQ VAL (REMOVEITEM NAME VAL FLG]
                 (SAVESET TEM VAL T 'NOPRINT)
                 T)))
            ((NEQ (CDR COM)
                  (SETQ TEM (REMOVEITEM NAME (CDR COM)
                                   FLG)))
             (/RPLACD COM TEM)
             (MARKASCHANGED COMSNAME 'VARS)
             T])

(REMOVEITEM
  [LAMBDA (X LST FLG)                                    (* ; "Edited 25-May-88 17:52 by drc:")
                                                             (* lmm "10-FEB-78 17:29")

    (* ;; 
  "returns a subset of LST with X deleted;  if FLG is set, also remove elements whose CAR is X")

    (COND
       [[OR (MEMBER X LST)
            (AND FLG (SOME LST (FUNCTION (LAMBDA (Y)
                                           (EQUAL (CAR (LISTP Y))
                                                  X]
        (SUBSET LST (FUNCTION (LAMBDA (Y)
                                (AND (NOT (EQUAL Y X))
                                     (OR (NOT FLG)
                                         (NLISTP Y)
                                         (NOT (EQUAL (CAR Y)
                                                     X]
       (T LST])

(MOVETOFILE
  [LAMBDA (TOFILE NAME TYPE FROMFILE)                    (* rmk%: "18-OCT-79 19:51")
                                                             (* ; "To move items between files")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    [COND
       ((OR (EQ TYPE 'FNS)
            FROMFILE)                                        (* ; 
       "FNS definition can reside on file if LOADFNS was done.  This guarantees that it is loaded.")
        (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM]
    (AND (EQ TYPE 'FNS)
         (MARKASCHANGED NAME TYPE))                      (* ; 
                                                   "FNS won't get dumped unless they are `changed'")
    (DELFROMFILES NAME TYPE FROMFILE)
    (ADDTOFILE NAME TYPE TOFILE])
)

(MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)

(MOVD? 'MOVETOFILE 'MOVEITEM NIL T)

(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)



(* ; "functions for doing things and marking them changed and auxiliary functions")

(DEFINEQ

(SAVEPUT
  [LAMBDA (ATM PROP VAL)                                 (* lmm " 7-May-84 16:56")

    (* ;; "analogous to SAVESET but also marks changed property lists;  LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT")

    [COND
       ((NOT (LITATOM ATM))
        (ERRORX (LIST 14 ATM]
    (PROG ((X (GETPROPLIST ATM))
           X0 TEM OLDFLG)
      LOOP
          (COND
             ((NLISTP X)
              (COND
                 ((AND (NULL X)
                       X0)                                   (* ; 
                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")
                  (SETQ TEM (LIST PROP VAL))
                  (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                        LISPXHIST))
                  (FRPLACD (CDR X0)
                         TEM)
                  (GO RET)))

              (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")

              )
             ((NLISTP (CDR X))

              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning.")

              )
             [(EQ (CAR X)
                  PROP)
              (SETQ OLDFLG (NEQ (EQUALN (CADR X)
                                       VAL 400)
                                T))                          (* ; "i.e. it probably changed")
              (/RPLACA (CDR X)
                     VAL)
              (COND
                 ((NOT OLDFLG)
                  (GO RET1))
                 (T (OR (EQ DFNFLG T)
                        (LISPXPRINT (LIST 'new PROP 'property 'for ATM)
                               T T))
                    (GO RET]
             (T (SETQ X (CDDR (SETQ X0 X)))
                (GO LOOP)))
          [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM]
          (SETPROPLIST ATM TEM)
          (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                LISPXHIST))
      RET (MARKASCHANGED (LIST ATM PROP)
                 'PROPS
                 (NOT OLDFLG))
      RET1
          (AND ADDSPELLFLG (ADDSPELL ATM 0))
          (RETURN VAL])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
    (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT))
)
(DEFINEQ

(UNMARKASCHANGED
  [LAMBDA (NAME TYPE)                                    (* JonL "24-Jul-84 19:59")

    (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties.  Value is name if anything is done")

    (PROG (ANYFLG)
          (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE
                                                                          TYPE
                                                                          'TYPE]
             while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL)
                                                               (SETQ ANYFLG T))
          [for F TAIL PROP TYPEDPROP in FILELST
             when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP
                                                    (ASSOC TYPE (fetch TOBEDUMPED
                                                                   of (SETQ PROP
                                                                           (fetch FILEPROP
                                                                              of F]
             do (SETQ ANYFLG T)
                   (COND
                      ((SETQ TAIL (REMOVE (CAR TAIL)
                                         (CDR TYPEDPROP)))
                       (/RPLACD TYPEDPROP TAIL))
                      (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP
                                                                              (fetch TOBEDUMPED
                                                                                 of PROP]
          (RETURN (AND ANYFLG NAME])

(PREEDITFN
  [LAMBDA (ATM TYPE EDITCHANGES)                         (* rmk%: "18-FEB-82 21:49")
                                                             (* ; 
                                           "EDITL is advised to call this before editing something")
    (AND FILEPKGFLG (SELECTQ TYPE
                        (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                   (CONS))
                                                            CLISPARRAY))
                                      (for X in (GETPROPLIST ATM)
                                         do (OR (NLISTP X)
                                                    (GETHASH X CLISPARRAY)
                                                    (PUTHASH X (CONS (CAR X)
                                                                     (CDR X))
                                                           CLISPARRAY]

                                 (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made")

                                 [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS)
                                                      EDITCHANGES
                                                      (APPEND (GETPROPLIST ATM])
                        (VARS [COND
                                 ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE))
                                  [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                    (CONS))
                                                             CLISPARRAY))
                                       (for X in (EVALV ATM)
                                          do (OR (NLISTP X)
                                                     (GETHASH X CLISPARRAY)
                                                     (PUTHASH X (CONS (CAR X)
                                                                      (CDR X))
                                                            CLISPARRAY]
                                  (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS)
                                                       EDITCHANGES
                                                       (for X in (EVALV ATM)
                                                          collect (CAR X])
                        NIL])

(POSTEDITPROPS
  [LAMBDA (EDITCHANGES OLDPROPS)                         (* rmk%: "18-FEB-82 21:50")
                                                             (* ; "was RESETSAVE'd from PREEDITFN")
    (PROG (OV FOUNDCHANGE)
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP)
                 when (for OLDPROP on OLDPROPS by (CDDR OLDPROP)
                             do (COND
                                       ((EQ (CAR OLDPROP)
                                            (CAR NEWPROP))   (* ; "Found the property")
                                        [AND (EQ (CADR OLDPROP)
                                                 (CADR NEWPROP))
                                             (COND
                                                ((NLISTP (CADR OLDPROP))
                                                             (* ; "value is same")
                                                 (RETURN))
                                                ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP)
                                                                                 CLISPARRAY))
                                                      (EQ (CAADR NEWPROP)
                                                          (CAR OV))
                                                      (EQ (CDADR NEWPROP)
                                                          (CDR OV)))
                                                 (PUTHASH (CADR NEWPROP)
                                                        NIL CLISPARRAY)
                                                             (* ; 
                                         "value has been edited (CLISPARRAY translation went away)")
                                                 (RETURN]
                                        (RETURN T))) finally 
                                                             (* ; "didn't find the property")
                                                           (RETURN T))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 (CAR NEWPROP))
                               'PROPS NIL)
                       (SETQ FOUNDCHANGE T))
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])

(POSTEDITALISTS
  [LAMBDA (EDITCHANGES OLDTOKENS)                        (* rmk%: " 4-JAN-82 10:14")
    (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES]
                                                             (* ; 
                                                           "called after an ALIST has been edited")
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 X)
                               'ALISTS NIL)
                       (SETQ FOUNDCHANGE T))
              [for NEWENTRY in NEWENTRIES
                 do (COND
                           ([AND (LISTP NEWENTRY)
                                 (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY))
                                           (EQ (CAR NEWENTRY)
                                               (CAR OV))
                                           (EQ (CDR NEWENTRY)
                                               (CDR OV]
                            (PUTHASH NEWENTRY NIL CLISPARRAY)
                            (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                     (CAR NEWENTRY))
                                   'ALISTS NIL)
                            (SETQ FOUNDCHANGE T]
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])
)

(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
                       (PUTPROP . SAVEPUT))



(* ; "sub-functions for file package commands & types")

(DEFINEQ

(ALISTS.GETDEF
  [LAMBDA (NAME TYPE OPTIONS)                            (* Pavel " 7-Oct-86 17:24")
    (AND (LISTP NAME)
         (CL:SYMBOLP (CAR NAME))
         (LET [(ASSOCIATION (ASSOC (CADR NAME)
                                   (GETTOPVAL (CAR NAME]
              (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME)
                                     ASSOCIATION])

(ALISTS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm "16-OCT-78 20:02")
                                                             (* ; 
                                          "called by MARKASCHANGED when an ALIST entry has changed")
    (PROG [(VARTYPE (GETPROP (CAR NAME)
                           'VARTYPE]
          (AND (LISTP VARTYPE)
               (EQ (CAR VARTYPE)
                   'ALIST)
               (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME)
                                              (CADR VARTYPE)
                                              NEWFLG])

(CLEARCLISPARRAY
  [LAMBDA (NAME TYPE REASON)
    (DECLARE (SPECVARS NAME TYPE REASON))            (* lmm "14-Aug-84 15:03")
    (AND CLISPARRAY (MAPHASH CLISPARRAY (COND
                                           [(EQ TYPE 'I.S.OPRS)
                                            (FUNCTION (LAMBDA (TRAN FORM)
                                                        (AND (MEMB NAME FORM)
                                                             (PUTHASH FORM NIL CLISPARRAY]
                                           (T                (* ; "MACRO changed")
                                              (FUNCTION (LAMBDA (TRAN FORM)
                                                          (COND
                                                             ((OR (EQ NAME (CAR FORM))
                                                                  (EQ (CAR (GETPROP (CAR FORM)
                                                                                  'CLISPWORD))
                                                                      'CHANGETRAN))
                                                              (PUTHASH FORM NIL CLISPARRAY])

(EXPRESSIONS.WHENCHANGED
  [LAMBDA (EXPR)                                         (* ; "Edited  6-Apr-87 20:21 by Pavel")
    (SELECTQ (CAR EXPR)
        ((SETQ SETQQ) 
             (UNMARKASCHANGED (CADR EXPR)
                    'VARS))
        ((PROGN PROG) 
             (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X)))
        NIL])

(MAKEALISTCOMS
  [NLAMBDA X                                             (* rmk%: "14-OCT-83 13:34")

    (* ;; "make command to dump prettydefmacros")

    (LIST
     (CONS 'ADDVARS
           (for PR in X
              join (for ALISTNAME inside (CAR PR)
                          collect (CONS ALISTNAME
                                            (for ATNAME inside (CDR PR) bind ENTRY
                                               when (SETQ ENTRY
                                                         (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME))
                                                             (PROGN (LISPXPRINT (LIST 'no ATNAME
                                                                                      'entry
                                                                                      'on ALISTNAME)
                                                                           T T)
                                                                    NIL))) collect ENTRY])

(MAKEFILESCOMS
  [NLAMBDA FILES                                         (* JonL "12-FEB-83 19:02")

    (* ;; "This scans the command just to warn the user about any errors.  Must match up with the big SELECTQ in FILESLOAD NIL")

    [for FILE in FILES
       do
       (OR
        (LITATOM FILE)
        (while (LISTP FILE)
           do (SELECTQ (CAR (OR (LISTP FILE)
                                    (RETURN)))
                      ((LOADCOMP LOADFROM))
                      (FROM (pop FILE)
                            (if (OR (EQ (CAR FILE)
                                            'VALUEOF)
                                        (if (AND (EQ (CAR FILE)
                                                         'VALUE)
                                                     (EQ (CADR FILE)
                                                         'OF))
                                            then (pop FILE)))
                                then (pop FILE)))
                      ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR))
                      (OR (FMEMB (CAR FILE)
                                 LOADOPTIONS)
                          (PRINT (CONS (CAR FILE)
                                       '(-- unrecognized FILES option))
                                 T)))
                 (pop FILE]
    (CONS 'FILESLOAD FILES])

(MAKELISPXMACROSCOMS
  [NLAMBDA X                                             (* lmm " 5-SEP-78 23:15")
    (PROG (TEM TEM2)
          (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                   LISPXHISTORYMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXHISTORYMACROS TEM)))
                                                       (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                          LISPXMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXMACROS TEM]
                        (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z LISPXCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2]
                                          (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z HISTORYCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2])

(MAKEPROPSCOMS
  [NLAMBDA X                                             (* lmm "26-FEB-78 17:10")

    (* ;; "make command to dump PROPS")

    (for PAIR in X collect (CONS 'PROP (CONS (COND
                                                            ((AND (LISTP (CDR PAIR))
                                                                  (NULL (CDDR PAIR)))
                                                             (CADR PAIR))
                                                            (T (CDR PAIR)))
                                                         (OR (LISTP (CAR PAIR))
                                                             (LIST (CAR PAIR])

(MAKEUSERMACROSCOMS
  [NLAMBDA X                                             (* rmk%: " 3-JAN-82 23:20")
    (PROG (TEM)
          [COND
             [X (for Y in X
                   do (OR (FASSOC Y USERMACROS)
                              (FASSOC Y EDITMACROS)
                              (LISPXPRINT (CONS Y '(-- no entry on USERMACROS))
                                     T T]
             (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR))
                               X]
          (RETURN (LIST (CONS 'ADDVARS
                              (NCONC (for VAR in '(USERMACROS EDITMACROS)
                                        when (SETQ TEM (for Y in (GETTOPVAL VAR)
                                                              when (FMEMB (CAR Y)
                                                                              X) collect Y))
                                        collect (CONS VAR TEM))
                                     (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS 
                                                                 DONTSAVEHISTORYCOMS)
                                        when [SETQ TEM
                                                  (SUBSET (GETTOPVAL LST)
                                                         (FUNCTION (LAMBDA (Y)
                                                                     (OR (FMEMB Y X)
                                                                         (AND (LISTP Y)
                                                                              (FMEMB (CAR Y)
                                                                                     X]
                                        collect (CONS LST TEM])

(PROPS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm " 7-SEP-78 22:08")
    (PROG [(PROPTYPE (GETPROP (CADR NAME)
                            'PROPTYPE]
          (COND
             [PROPTYPE (RETFROM 'MARKASCHANGED (COND
                                                  ((NEQ PROPTYPE 'IGNORE)
                                                   (MARKASCHANGED (CAR NAME)
                                                          PROPTYPE NEWFLG]
             (T (SELECTQ (CADR NAME)
                    (CLISPWORD (CLEARCLISPARRAY (CAR NAME)))
                    NIL])

(FILEGETDEF.LISPXMACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:12")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (EQ FIRST 'ADDTOVAR)
                                                                   (MEMB SECOND '(LISPXMACROS 
                                                                                        LISPXCOMS))
                                                                   T]
                when (SELECTQ (CADR X)
                             (LISPXMACROS                    (* ; 
                      "Rebuild the expressions cause there might be other elements in the ADDTOVAR")
                                          (AND (SETQ X (ASSOC NAME (CDDR X)))
                                               (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X))))
                             (LISPXCOMS [COND
                                           ((MEMB NAME (CDDR X))
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME)))
                                           ((SETQ X (ASSOC NAME (CDDR X)))
                                                             (* ; "For synonym pairs")
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X])
                             NIL) collect X])

(FILEGETDEF.ALISTS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'ADDTOVAR)
                                                          (EQ SECOND (CAR NAME]
       when (SETQ X (ASSOC (CADR NAME)
                               (CDDR X))) collect X
       finally (RETURN (COND
                              ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.RECORDS
  [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND)            (* lmm "26-Jun-86 15:56")
    (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                              (AND (MEMB FIRST CLISPRECORDTYPES)
                                                   (OR (EQ SECOND NAME)
                                                       (AND (MEMB SECOND '(%( %[))
                                                            (PROGN (RATOM)
                                                                   (RATOM)
                                                                   (RATOM)
                                                                   (EQ NAME (RATOM]
         (if (EQ (CAAR VAL)
                     'NOT-FOUND%:)
             then NOTFOUND
           elseif (CDR VAL)
             then (CONS 'PROGN VAL)
           else (CAR VAL])

(FILEGETDEF.PROPS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'PUTPROPS)
                                                          (EQ SECOND (CAR NAME]
       join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL)
                                                                              (CADR NAME))
                   join (LIST (CAR TAIL)
                                  (CADR TAIL)))
       finally (RETURN (COND
                              ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.MACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "28-May-86 09:51")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (FMEMB FIRST '(PUTPROPS DEFMACRO))
                                                                   (EQ SECOND NAME]
                join (if (EQ (CAR X)
                                     'DEFMACRO)
                             then (LIST X)
                           else (for TAIL on (CDDR X) by (CDDR TAIL)
                                       when (FMEMB (CAR TAIL)
                                                       MACROPROPS) collect (LIST 'PUTPROPS
                                                                                     (CADR X)
                                                                                     (CAR TAIL)
                                                                                     (CADR TAIL])

(FILEGETDEF.VARS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:14")
    (for X in (LOADFNS NIL SOURCE 'GETDEF NAME)
       do (SELECTQ (CAR X)
                  ((RPAQQ SETQQ) 
                       (RETURN (CADDR X)))
                  ((RPAQ SETQ RPAQ?) 
                       (RETURN (EVAL (CADDR X))))
                  NIL) finally (RETURN 'NOBIND])

(FILEGETDEF.FNS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: "29-Aug-86 22:30")
    (LET (MAP ENV)
         (COND
            [(AND (EQMEMB 'FAST OPTIONS)
                  (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
                                (GET-ENVIRONMENT-AND-FILEMAP SOURCE))
                         MAP))
             (for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME
                                                                                      (CDDR PAIR]
                do [OR (OPENP SOURCE)
                           (RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
                                                                             'OLD]
                      (SETFILEPTR SOURCE MAPLOC)
                      (RETURN (WITH-READER-ENVIRONMENT ENV
                                  [COND
                                     ((EQMEMB 'ARGLIST OPTIONS)
                                      (RATOM SOURCE)
                                      (READ SOURCE)
                                      (RATOM SOURCE)
                                      (LIST (READ SOURCE)
                                            (READ SOURCE)))
                                     (T (CADR (READ SOURCE])]
            (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])

(FILEPKGCOMS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 11:29")
    (PROG (COM TYP)
          [SELECTQ (CAR (LISTP DEFINITION))
              (COM (SETQ COM (CDR DEFINITION)))
              (TYPE (SETQ TYP (CDR DEFINITION)))
              (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION)))
                     (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION]

     (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE")

          (for I in COM by (CDDR I) do (SELECTQ I
                                                           ((ADD DELETE MACRO CONTENTS CONTAIN COM))
                                                           (ERROR I 
                                                                  "not file package command property"
                                                                  )))
                                                             (* ; 
                                                   "COM merely adds to spelling list, for builtins")
          [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS)
                                             (LISTGET COM 'CONTAIN]
                                                             (* ; "Until CONTAIN is de-documented.")
          (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP
                                                                         (LISTGET COM PROP)))
          [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS)
                                                           (SELECTQ I
                                                               ((DESCRIPTION TYPE))
                                                               (ERROR I 
                                                             "not file package type/command property"
                                                                      ]
                                                             (* ; 
                                                  "TYPE merely adds to spelling list, for builtins")
          (for PROP in (UNION '(DESCRIPTION TYPE)
                                      FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP
                                                                      (LISTGET TYP PROP])

(FILES.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 17:13")
    (PROGN (PUTDEF (FILECOMS NAME)
                  'VARS
                  (CAR DEFINITION)
                  REASON)                                    (* ; "DEFINE THE COMS")
           (ADDFILE NAME)                                (* ; 
                                                           "MAKE SURE IT IS A FILE PACKAGE ENTITY")
           [/replace TOBEDUMPED of (fetch FILEPROP of NAME)
                                          (FILEPKG.MERGECHANGES (CADR DEFINITION)
                                                 (fetch TOBEDUMPED of (fetch FILEPROP
                                                                                 of NAME]
           (OR (fetch FILEDATES of NAME)
               (/replace FILEDATES of NAME with (CADDR DEFINITION])

(VARS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "29-Jul-85 20:59")
    (/SETTOPVAL NAME DEFINITION T])

(FILES.WHENCHANGED
  [LAMBDA (NAME TYPE REASON)
    (MARKASCHANGED (FILECOMS NAME)
           'VARS REASON])
)

(ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO)

(ADDTOVAR SYSPROPS PROPTYPE)

(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)

(PUTPROPS SUBR PROPTYPE IGNORE)

(PUTPROPS LIST PROPTYPE IGNORE)

(PUTPROPS CODE PROPTYPE IGNORE)

(PUTPROPS FILEDATES PROPTYPE IGNORE)

(PUTPROPS FILE PROPTYPE IGNORE)

(PUTPROPS FILEMAP PROPTYPE IGNORE)

(PUTPROPS EXPR PROPTYPE FNS)

(PUTPROPS VALUE PROPTYPE VARS)

(PUTPROPS COPYRIGHT PROPTYPE FILES)

(PUTPROPS FILETYPE PROPTYPE FILES)

(PUTPROPS BAKTRACELST VARTYPE ALIST)

(PUTPROPS BREAKMACROS VARTYPE ALIST)

(PUTPROPS COMPILETYPELST VARTYPE ALIST)

(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))

(PUTPROPS ERRORTYPELST VARTYPE ALIST)

(PUTPROPS FONTDEFS VARTYPE ALIST)

(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))

(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)

(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)

(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)

(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))



(* ; "Define the commands below AFTER the various properties have been established.")


(ADDTOVAR USERMACROS
          (M NIL (MAKE FILE FILE))
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITMACROS
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITCOMSA M)

(ADDTOVAR EDITCOMSL M)



(* ; "GETDEF methods")

(DEFINEQ

(RENAME
  [LAMBDA (OLD NEW TYPES FILES METHOD)               (* JonL "24-Jul-84 20:01")
    (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD)))

     (* ;; "special kludge: change the callers BEFORE if we are changing a field;  this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message")

          [for TYPE inside TYPES when (NEQ TYPE 'FIELDS)
             do (COPYDEF OLD NEW TYPE NIL (COND
                                                     ((EQ TYPE 'VARS)
                                                      'NOERROR]
          (CHANGECALLERS OLD NEW TYPES FILES METHOD)
          [for TYPE inside TYPES do (COND
                                                   ((AND (EQ TYPE 'FIELDS)
                                                         (HASDEF OLD 'FIELDS))

                                 (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file.  Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.")

                                                    (COPYDEF OLD NEW 'FIELDS))
                                                   (T (DELDEF OLD TYPE]
          (RETURN NEW])

(CHANGECALLERS
  [LAMBDA (OLD NEW AS-TYPES FILES METHOD)            (* ; "Edited  6-Dec-86 01:25 by lmm")
    (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES))
           REL TEM EDITCOMS FNS)
          (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD))
          [SETQ EDITCOMS
           (LIST (COND
                    [(OR (EQMEMB 'CAREFUL METHOD)
                         (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES))
                                (printout T "Warning --" OLD " is also defined as " TEM T)))

                     (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename.  Y means do it, No means skip, anything else goes into TTY.")

                     (SUBPAIR '(OLD NEW)
                            (LIST OLD NEW)
                            '(BIND (LPQ (F OLD N)
                                            (MARK %#1)
                                            (ORR (1 !0 P)
                                                 NIL)
                                            (MARK %#2)
                                            (COMS (SELECTQ (ASKUSER NIL NIL "   Replace ? "
                                                                  '((Y "Yes
")
                                                                    (N "No
")
                                                                    (%
 "")
                                                                    (%  "")
                                                                    (%
 "")
                                                                    (& ""))
                                                                  NIL NIL '(NOECHOFLG T))
                                                      (Y '(R1 OLD NEW))
                                                      (N NIL)
                                                      'TTY%:))
                                            (MARK %#3)
                                            (IF (EQ (%## (\ %#3))
                                                        (%## (\ %#2)))
                                                   ((\ %#1))
                                                   NIL]
                    (T (LIST 'R OLD NEW]
          (SELECTQ (COND
                      ((AND (EQMEMB 'MASTERSCOPE METHOD)
                            MSDATABASELST
                            (for TYPE inside AS-TYPES
                               do [COND
                                         ((SETQ TEM (SELECTQ TYPE
                                                        ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 
                                                             'CALL)
                                                        (MACROS '(CALL DIRECTLY))
                                                        ((VARS VARIABLES) 
                                                             '(USE OR BIND))
                                                        ((RECORDS FIELDS I.S.OPRS) 
                                                             (LIST 'USE 'AS TYPE))
                                                        (RETURN NIL)))
                                          (COND
                                             (REL (SETQ REL (LIST TEM 'OR REL)))
                                             (T (SETQ REL TEM] FINALLY (RETURN REL)))

                       (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known")

                       'MASTERSCOPE)
                      ((EQMEMB 'EDITCALLERS METHOD)
                       'EDITCALLERS)
                      (T 'SEARCH))
              (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND
                                                     ((NULL FILES)
                                                      (UPDATEFILES)
                                                      (FILEPKGCHANGES 'FNS]
                                                  (for FILE inside (OR FILES FILELST)
                                                     join (FILEFNSLST FILE]
                                 (FUNCTION UPDATEFN))
                           (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL))
                                                          T)
                                            FNS)))
              (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST)
                                          when (SETQ TEM (EDITCALLERS OLD X T))
                                          collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM)))
                                                             X))))
              (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST
                                                                                   X))))
              (ERROR "UNRECOGNIZED RENAME METHOD" METHOD))
          (AND (EQMEMB 'FNS AS-TYPES)
               (FMEMB OLD FNS)
               (SETQ FNS (REMOVE OLD FNS)))
          (EDITFROMFILE FNS FILES OLD EDITCOMS)
          [for TYPE inside AS-TYPES
             do (for FILE in (WHEREIS OLD TYPE FILES)
                       do (AND (ADDTOFILE NEW TYPE FILE)
                                   (DELFROMFILES OLD TYPE FILE)
                                   (printout T OLD " changed to " NEW " on " FILE)))
                   (COND
                      ((SETQ TEM (WHEREIS OLD TYPE FILES))
                       (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM]
          (COND
             (REL (UPDATECHANGED)
                  (COND
                     ((AND (SETQ TEM (GETRELATION OLD REL T))
                           (WHEREIS TEM 'FNS FILES))
                      (printout T "Couldn't find where " OLD " is referenced in " TEM T])
)
(DEFINEQ

(SHOWDEF
  [LAMBDA (NAME TYPE FILE)                              (* ; "Edited 16-Apr-2018 21:35 by rmk:")
                                                             (* ; 
                                                 "prettyprint NAME as it would be dumped as a TYPE")
    (RESETLST
        (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
              (DECLARE (SPECVARS . T))
              [AND FILE (NEQ FILE (OUTPUT))
                   (if (SETQ FL (OPENP FILE 'OUTPUT))
                       then (RESETSAVE (OUTPUT FL))
                     else (OUTFILE FILE)
                           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                                (OUTPUT]
              (PRETTYCOM (MAKENEWCOM NAME TYPE))))])

(COPYDEF
  [LAMBDA (OLD NEW TYPE SOURCE OPTIONS)              (* lmm "14-Aug-84 18:38")
                                                             (* ; "like MOVD, but takes a type.")
    (PROG (TEM DEF)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          [SETQ DEF (GETDEF OLD TYPE SOURCE (COND
                                                   ((EQ OPTIONS 'NOCOPY)
                                                    NIL)
                                                   (T (REMOVE 'NOCOPY (MKLIST OPTIONS]
                                                             (* ; 
      "The default is for GETDEF to return a COPY.  Make sure that NOCOPY isn't in options though.")
          (SELECTQ TYPE
              (VARS)
              (FILES [for X in (CAR DEF)
                        do                               (* ; 
                                          "change all the listnames which are of form filenameTYPE")
                              (SELECTQ (CAR X)
                                  ((PROP IFPROP) 
                                       (SETQ X (CDR X)))
                                  NIL)
                              (COND
                                 ((EQ (CADR X)
                                      '*)
                                  (SETQ X (CDDR X))
                                  (COND
                                     ((AND (LITATOM (CAR X))
                                           (SETQ TEM (STRPOS OLD (CAR X)
                                                            1 NIL T T)))
                                      (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X)
                                                                           TEM -1)))
                                             (COPY (GETTOPVAL (CAR X)))
                                             T)
                                      (FRPLACA X TEM])
              ((PROPS ALISTS) 
                   (OR (EQ (CAR NEW)
                           (CAR OLD))
                       (DSUBST (CAR NEW)
                              (CAR OLD)
                              DEF))
                   (OR (EQ (CADR NEW)
                           (CADR OLD))
                       (DSUBST (CADR NEW)
                              (CADR OLD)
                              DEF)))
              (DSUBST NEW OLD DEF))
          (PUTDEF NEW TYPE DEF)
          (RETURN NEW])

(GETDEF
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "13-Jul-85 04:10")

    (* ;; "returns the definition of NAME as a TYPE from SOURCE;  cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found.  The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.")

    (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS)))
          (DECLARE (SPECVARS NOCOPY))
          (SELECTQ OPTIONS
              (0 (SETQQ OPTIONS (NOERROR NODWIM))
                 (SETQ NOCOPY T))
              (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST))
                 (SETQ NOCOPY T))
              (T (SETQQ OPTIONS SPELL))
              NIL)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          (SELECTQ SOURCE
              (0 (SETQQ SOURCE CURRENT))
              (T (SETQQ SOURCE SAVED))
              (NIL (SETQQ SOURCE ?))
              NIL)
          [SELECTQ SOURCE
              (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS)))
              (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS]
                      (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS])
              (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS)))
              (COND
                 ((AND (LISTP SOURCE)
                       (EQ (CAR SOURCE)
                           '=))
                  (SETQ DEF (CDR SOURCE)))
                 (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS))
                    (SETQ NOCOPY T]
          (OR NOCOPY (SETQ DEF (COPY DEF)))
          (COND
             ((AND (EQ TYPE 'FNS)
                   (NOT (EQMEMB 'NODWIM OPTIONS)))
              (DWIMDEF DEF NAME SOURCE)))
          (RETURN DEF])

(GETDEFCOM
  [LAMBDA (X)                                            (* lmm " 4-Jul-85 13:31")

    (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in.  Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed.  --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.  That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.")
                                                             (* ; "a RETFROM point")
    (for Y in X join (GETDEFCOM0 Y])

(GETDEFCOM0
  [LAMBDA (COM)                                          (* wt%: " 7-FEB-79 23:28")
    (PROG (TEM)
          (RETURN (COND
                     ((SETQ TEM (fetch MACRO of (CAR COM)))
                                                             (* COND ((fetch CONTENTS of
                                                           (CAR COM)) (* ; 
                        "if it has a CONTENTS function, generally means it is not safe to evaluate")
                                                           (RETFROM (QUOTE GETDEFCOM))))
                      (for Y in (SUBPAIR (CAR TEM)
                                               (PRETTYCOM1 COM)
                                               (CDR TEM)) join (GETDEFCOM0 Y)))
                     (T (SELECTQ (CAR COM)
                            (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X)))
                            (ADDVARS (for Y in (PRETTYCOM1 COM)
                                        collect (CONS 'ADDTOVAR Y)))
                            (APPENDVARS (for Y in (PRETTYCOM1 COM)
                                           collect (CONS 'APPENDTOVAR Y)))
                            (P (APPEND (PRETTYCOM1 COM)))
                            (RETFROM 'GETDEFCOM])

(GETDEFCURRENT
  [LAMBDA (NAME TYPE OPTIONS)                            (* ; "Edited  2-May-87 19:00 by Pavel")
                                                             (* ; 
                                                           "Gets the current definition--source=0")
    (LET
     (DEF)
     (COND
        ((AND (SETQ DEF (fetch GETDEF of TYPE))
              (NEQ DEF T))

         (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")

         (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS))
                  (fetch NULLDEF of TYPE))
             (GETDEFERR NAME TYPE OPTIONS))
         DEF)
        (T
         (OR
          (NEQ
           [SETQ DEF
            (SELECTQ TYPE
                (FNS (AND (LITATOM NAME)
                          (EXPRP (SETQ DEF (VIRGINFN NAME)))
                          DEF))
                (VARS (if (LITATOM NAME)
                          then (GETTOPVAL NAME)
                        else 'NOBIND))
                ((FIELDS RECORDS) 
                     (if (LITATOM NAME)
                         then [SETQ DEF (SELECTQ TYPE
                                                (RECORDS (RECLOOK NAME))
                                                (MKPROGN (FIELDLOOK NAME]
                               (if (EQMEMB 'EDIT OPTIONS)
                                   then (COPY DEF)
                                 else DEF)))
                (FILES                                       (* ; 
              "what is the `definition' of a file?  -- I guess the COMS which say what it contains")
                       [if (LITATOM NAME)
                           then (if (SETQ DEF (GETFILEDEF NAME))
                                        then (UPDATEFILES)
                                              (LIST (LISTP (GETTOPVAL (FILECOMS DEF)))
                                                    (fetch TOBEDUMPED
                                                       of (fetch FILEPROP of DEF))
                                                    (LISTP (fetch FILEDATES of DEF])
                (TEMPLATES (if (AND (LITATOM NAME)
                                        (SETQ DEF (GETTEMPLATE NAME)))
                               then (LIST 'SETTEMPLATE (KWOTE NAME)
                                              (KWOTE DEF))))
                (MACROS [if [AND (LITATOM NAME)
                                     (SETQ DEF (for X on (GETPROPLIST NAME)
                                                  by (CDDR X) when (FMEMB (CAR X)
                                                                                  MACROPROPS)
                                                  join (LIST (CAR X)
                                                                 (CADR X]
                            then `(PUTPROPS ,NAME ,@DEF])
                (EXPRESSIONS (LISTP NAME))
                (PROPS [AND (LISTP NAME)
                            (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME))
                                                 [FUNCTION (LAMBDA (X)
                                                             (EQ X (CADR NAME]
                                                 (FUNCTION CDDR)))
                                 (LIST 'PUTPROPS (CAR NAME)
                                       (CADR NAME)
                                       (CADR DEF])
                (FILEPKGCOMS [AND (LITATOM NAME)
                                  (PROG ((COM (FILEPKGCOM NAME))
                                         (TYP (FILEPKGTYPE NAME)))
                                        (RETURN (COND
                                                   ((AND COM TYP)
                                                    (LIST (CONS 'COM COM)
                                                          (CONS 'TYPE TYP)))
                                                   (COM (LIST (CONS 'COM COM)))
                                                   (TYP (LIST (CONS 'TYPE TYP])
                (FILEVARS (COND
                             ((AND (LITATOM NAME)
                                   (LISTP (SETQ DEF (GETTOPVAL NAME)))
                                   (WHEREIS NAME 'FILEVARS))
                              DEF)
                             (T 'NOBIND)))
                (LET
                 ((COMS (LIST (MAKENEWCOM NAME TYPE)))
                  FILE)
                 [COND
                    ((NOT (SETQ DEF (GETDEFCOM COMS)))
                     (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
                         (RESETLST
                             (RESETSAVE PRETTYFLG)
                             (RESETSAVE FONTCHANGEFLG)
                             [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
                             (PRETTYDEFCOMS COMS)
                             (SETFILEPTR FILE 0)
                             [SETQ DEF
                              (for X in (READFILE FILE)
                                 join
                                 (SELECTQ (CAR X)
                                     ((*) 
                                          NIL)
                                     (DECLARE%: (for Y on (CDR X)
                                                   unless (SELECTQ (CAR Y)
                                                                  ((COPYWHEN EVAL@LOADWHEN 
                                                                          EVAL@COMPILEWHEN) 
                                                                       (RETURN (LIST Y)))
                                                                  (FMEMB (CAR Y)
                                                                         DECLARETAGSLST))
                                                   collect (CAR Y)))
                                     (CL:EVAL-WHEN (CDDR X))
                                     (PROGN (CDR X))
                                     (LIST X]
                             (SETQ NOCOPY T)))]
                 (MKPROGN DEF]
           (fetch NULLDEF of TYPE))
          (GETDEFERR NAME TYPE OPTIONS))
         DEF])

(GETDEFERR
  [LAMBDA (NAME TYPE OPTIONS MSG)                        (* lmm "13-Jul-85 04:11")
    (DECLARE (USEDFREE NODEF))                           (* ; 
                                       "Message non-null if looking for saved or filed definition.")
    (PROG (TEM)
          (RETURN (COND
                     ((EQMEMB 'NOERROR OPTIONS)              (* ; 
                                               "We want to do the string search in the HASDEF case")
                      (RETURN (fetch NULLDEF of TYPE)))
                     [(AND (NULL MSG)
                           (EQMEMB 'SPELL OPTIONS)
                           (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS)
                                                                          'SPELL)
                                                                   T)))
                           (NEQ TEM NAME))
                      (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS]
                     (T (for O inside OPTIONS when (STRINGP O)
                           do (RETFROM 'GETDEF O)
                           finally (ERROR NAME (CONS TYPE '(definition not found))
                                              T])

(GETDEFFROMFILE
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: " 1-Oct-86 22:10")

    (* ;; "Tries to get definition from source file.  If successful, returns the definition.  Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.")

    (DECLARE (SPECVARS NAME))
    (bind (NOTFOUND _ "not found")
           DEF SOURCE TEM2 for FILE inside (COND
                                                      ((EQ SOURCE 'FILE)
                                                       (WHEREIS NAME TYPE T))
                                                      (T SOURCE))
       when
       (AND
        (SETQ SOURCE (FINDFILE FILE T))
        (NEQ
         [SETQ DEF
          (COND
             ((SETQ TEM2 (fetch FILEGETDEF of TYPE))
              (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND))
             (T
              (SELECTQ TYPE
                  (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  ((VARS FILEVARS) 
                       (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (COND
                     [(SETQ DEF (GET TYPE 'DEFINERS))
                      (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF
                                        `(LAMBDA (FIRST SECOND)
                                           (AND (MEMB FIRST ',DEF)
                                                (OR (EQ SECOND NAME)
                                                    (AND (MEMB SECOND '(%( %[))
                                                         (PROGN (RATOM)
                                                                (RATOM)
                                                                (RATOM)
                                                                (EQ NAME (RATOM]
                                                             (* ; "ick!  Should use real closure")
                           (if (EQ (CAAR VAL)
                                       'NOT-FOUND)
                               then NOTFOUND
                             elseif (CDR VAL)
                               then (CONS 'PROGN VAL)
                             else (CAR VAL]
                     (T (RESETLST
                            (RESETSAVE (RESETUNDO))
                            [LET (LOAD-VERBOSE-STREAM)
                                 (DECLARE (SPECVARS LOAD-VERBOSE-STREAM))
                                                             (* ; 
                                                     "just in case we get a PRETTYCOMPRINT in here")
                                 (LOADFNS NIL SOURCE 'PROP (COND
                                                              ((LITATOM NAME)
                                                             (* ; 
                                         "If an atom, only bother with expressions that contain it")
                                                               (CONS (LIST '& '|..| NAME)))
                                                              (T T]
                            (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))]
         NOTFOUND)) do (AND (EQ SOURCE 'FILE)
                                (OR (FMEMB FILE FILELST)
                                    (CL:FORMAT T "(from ~A)~%%" SOURCE))) 
                                                             (* ; 
                                                        "Copying and dwimifying are done in GETDEF")
                          (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
                                                                  (APPEND '(no definition on)
                                                                         (MKLIST SOURCE])

(GETDEFSAVED
  [LAMBDA (NAME TYPE OPTIONS)                          (* ; "Edited 11-Aug-87 18:14 by cutting")
                                                             (* ; 
                                                           "Gets the `saved' definition--source=T")
    (SELECTQ TYPE
        (FNS (OR (GETPROP NAME 'EXPR)
                 (GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
        (VARS                                                (* ; 
                               "The value of a variable is never substituted into and never COPIED")
              (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
                                                                                'VALUE)
                 do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS 
                                                                     "no saved value for "))))
        (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS)))
            (GETDEFERR NAME TYPE OPTIONS "no saved definition for "])

(PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* ; "Edited  8-Apr-87 12:52 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE)))
         (COND
            (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON))
            (T (SELECTQ TYPE
                   (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON))
                   (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON))
                   (EVAL DEFINITION))
               NAME])

(EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)
    (DECLARE (LOCALVARS . T)
           (SPECVARS SOURCE))                          (* ; "Edited 27-Jul-87 11:04 by cutting")

    (* ;; "lets you edit anything.  Given name and type, call editor on the definition (loading it in from SOURCE if necessary).  If you change it, then the definition gets unsaved.  OPTIONS is passed through from ED to the editor.")

    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (COND
       ((AND (fetch EDITDEF of TYPE)
             (APPLY* (fetch EDITDEF of TYPE)
                    NAME TYPE SOURCE EDITCOMS OPTIONS)))
       ((AND (EQ TYPE 'FNS)
             (NULL SOURCE))                                  (* ; 
                                "special hack for EDITDEF of FNS because of ability to EDITLOADFNS")
        (EDITDEF.FNS NAME EDITCOMS OPTIONS))
       (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))
    NAME])

(DEFAULT.EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 11-Jun-92 16:26 by cat")
    (PROG [(DEF (COND
                   [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
                   [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
                   [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
                   (T (LET ((FILES (WHEREIS NAME TYPE T)))
                           (CL:IF (NULL FILES)
                               (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE)
                               [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME 
                                                         FILES)
                                                  (CL:IF (CL:ENDP (CDR FILES))
                                                      (CL:IF (CL:Y-OR-N-P 
                                                                    "Shall I load this file PROP? ")
                                                             (CAR FILES))
                                                      (ASKUSER NIL NIL 
                                                             "indicate which file to load PROP: "
                                                             (MAKEKEYLST FILES)
                                                             T))]
                                    (CL:WHEN FILE
                                        (LOAD FILE 'PROP)
                                        (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])]

     (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")

          (DECLARE (SPECVARS RETRY))

     (* ;; "what is RETRY ???")

          (SETQ RETRY)
          (CL:WHEN DEF
              (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
                                                             (* ; 
                                             "this function is called when there were changes made")
                                                        (FIXEDITDATE DEF)
                                                             (* ; "fix the edit date first - jtm")
                                                        (PUTDEF NAME TYPE DEF)
                                                        (MARKASCHANGED NAME TYPE 'CHANGED)

                                 (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition.  doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here.  this sometimes results in MARKASCHANGED getting called twice.")

                                                        ]
                     OPTIONS))])

(EDITDEF.FILES
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 18-Mar-87 16:07 by woz")
    (EDITDEF (FILECOMS NAME)
           'VARS SOURCE EDITCOMS OPTIONS])

(LOADDEF
  [LAMBDA (NAME TYPE SOURCE)                             (* lmm "13-SEP-78 01:34")
    (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY])

(DWIMDEF
  [LAMBDA (DEF FN SOURCE)                                (* lmm " 6-Jun-86 17:23")
    (AND [OR (EQ DWIMIFYCOMPFLG T)
             (EQ CLISPIFYPRETTYFLG T)
             (EQ (CAR (CADDR DEF))
                 'CLISP%:)
             (SELECTQ SOURCE
                 ((CURRENT SAVED FILE ?) 
                      NIL)
                 (AND (LITATOM SOURCE)
                      (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE]
         (LET ((NOSPELLFLG T)
               (DWIMESSGAG T)
               FILEPKGFLG LISPXHIST)
              (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST))
              (DWIMIFY0 DEF (COND
                               ((OR (LISTP FN)
                                    (NULL FN))
                                '?)
                               (T FN))
                     NIL DEF])

(DELDEF
  [LAMBDA (NAME TYPE)                                    (* ; "Edited  5-Dec-86 06:20 by lmm")
    (PROG (TEM)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
      LP  [COND
             ((SETQ TEM (fetch DELDEF of TYPE))
              (APPLY* TEM NAME TYPE))
             (T (SELECTQ TYPE
                    (FNS                                     (* ; 
  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such")
                         (AND (EXPRP NAME)
                              (/PUTD NAME))
                         (REMPROP NAME 'EXPR)
                         [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME])
                    (VARS (/SETTOPVAL NAME 'NOBIND))
                    (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES)
                              do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST]
                           (/replace FILEPROP of NAME with NIL)
                           (/replace FILECHANGES of NAME with NIL)
                           (/replace FILEDATES of NAME with NIL)
                           (FLUSHFILEMAPS NAME))
                    (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME)
                                 (DELFROMLIST 'FILEPKGTYPES NAME)
                                 (for FIELD on (FILEPKGCOM NAME)
                                    by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD)
                                                                      NIL))
                                 (for FIELD on (FILEPKGTYPE NAME)
                                    by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD)
                                                                      NIL))
                                 (/replace ALLFIELDS of NAME with NIL))
                    (ALISTS [AND (LISTP NAME)
                                 (DELFROMLIST (CAR NAME)
                                        (FASSOC (CADR NAME)
                                               (GETTOPVAL (CAR NAME])
                    (MACROS (for P in MACROPROPS do (/REMPROP NAME P)))
                    (PROPS (AND (LISTP NAME)
                                (/REMPROP (CAR NAME)
                                       (CADR NAME))))
                    (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS))
                                 (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS
                                                                             ))
                                 (DELFROMLIST 'LISPXCOMS NAME)
                                 (DELFROMLIST 'HISTORYCOMS NAME))
                    (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet")
                           T]
          (MARKASCHANGED NAME TYPE 'DELETED)
          (RETURN NAME])

(DELFROMLIST
  [LAMBDA (VAR VAL)                                      (* rmk%: " 3-JAN-82 23:22")
    (AND (FMEMB VAL (GETTOPVAL VAR))
         (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR)
                                (FUNCTION (LAMBDA (X)
                                            (AND (NEQ X VAL)
                                                 (OR (NLISTP X)
                                                     (NEQ (CDR X)
                                                          VAL])

(HASDEF
  [LAMBDA (NAME TYPE SOURCE SPELLFLG)                    (* ; "Edited 31-Aug-87 18:02 by drc:")

    (* ;; "is NAME the name of something of type TYPE?  NIL SOURCE means 0, not ?")

    (DECLARE (SPECVARS TYPE))
    (COND
       [[OR (LISTP TYPE)
            (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG")
        (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
                                            (RETURN $$VAL]
       (T
        (PROG [(NODEF (fetch NULLDEF of TYPE))
               (OPTS '(NODWIM NOCOPY NOERROR HASDEF]
              (COND
                 ((NULL SOURCE)
                  (SETQQ SOURCE CURRENT)))
              (RETURN
               (SELECTQ SOURCE
                   ((CURRENT 0) 
                        [COND
                           ([OR
                             (MEMBER NAME (fetch CHANGED of TYPE))
                             (LET ((TM (fetch HASDEF of TYPE)))
                                  (COND
                                     (TM (APPLY* TM NAME TYPE SOURCE))
                                     [(NOT (LITATOM NAME))
                                      (SELECTQ TYPE
                                          (PROPS (AND (LISTP NAME)
                                                      (GETPROP (CAR NAME)
                                                             (CADR NAME))))
                                          ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS 
                                                  FIELDS USERMACROS FILEVARS FILEPKGCOMS) 
                                               NIL)
                                          (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                                     (T 
                                        (* ;; "symbol definitions")

                                        (SELECTQ TYPE
                                            (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS")
                                                                        "INTERLISP")))
                                                        (AND SYMBOL (BOUNDP SYMBOL))))
                                            (TEMPLATES (GETTEMPLATE NAME))
                                            (MACROS (GETLIS NAME MACROPROPS))
                                            (LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
                                                             (FASSOC NAME LISPXHISTORYMACROS)))
                                            (VARS (AND (NOT (CL:KEYWORDP NAME))
                                                       (NEQ (GETTOPVAL NAME)
                                                            'NOBIND)))
                                            (RECORDS (RECLOOK NAME))
                                            (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD]
                                                            (RETURN (AND TEM (EQ (CAR TEM)
                                                                                 'FORWORD)
                                                                         (GETPROP (CDR TEM)
                                                                                'I.S.OPR])
                                            (FNS (AND (OR (AND (GETD NAME)
                                                               (EXPRP (GETD NAME)))
                                                          (GET NAME 'EXPR))
                                                      (NOT (HASDEF NAME 'FUNCTIONS SOURCE))))
                                            (FIELDS (RECORDFIELD? NAME))
                                            (USERMACROS (FASSOC NAME USERMACROS))
                                            (FILEVARS)
                                            ((PROPS ALISTS DEFS EXPRESSIONS) 
                                                 NIL)
                                            (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
                                                             (FMEMB NAME FILEPKGTYPES)))
                                            (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                            (OR NAME T))
                           (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME)
                                         (FIXSPELL NAME NIL
                                                (SELECTQ TYPE
                                                    (FILES FILELST)
                                                    (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES))
                                                    (FIELDS (for X in USERRECLST
                                                               join (APPEND (RECORDFIELDNAMES
                                                                                 X))))
                                                    (RECORDS (for X in USERRECLST
                                                                when (LITATOM (CADR X))
                                                                collect (CADR X)))
                                                    (LISPXMACROS LISPXCOMS)
                                                    (I.S.OPRS I.S.OPRLST)
                                                    (USERMACROS (MAPCAR USERMACROS
                                                                       (FUNCTION CAR)))
                                                    USERWORDS)
                                                NIL
                                                (LISTP SPELLFLG)
                                                [FUNCTION (LAMBDA (X)
                                                            (HASDEF X TYPE 'CURRENT]
                                                NIL T))])
                   (? (OR (HASDEF NAME TYPE 'CURRENT)
                          (AND (LITATOM NAME)
                               (HASDEF NAME TYPE 'SAVED SPELLFLG))
                          (WHEREIS NAME TYPE T)))
                   ((SAVED T) 
                        (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS)))
                   (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])

(GETFILEDEF
  [LAMBDA (FILENAME)                                     (* lmm " 4-Jul-85 13:25")

    (* ;; 
  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST")

    (COND
       ((FMEMB FILENAME FILELST)
        FILENAME)
       (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T)
             do (COND
                       ((EQ (FILENAMEFIELD FILE 'NAME)
                            FILENAME)
                        (RETURN FILE])

(SAVEDEF
  [LAMBDA (NAME TYPE DEFINITION)                         (* JonL "24-Jul-84 20:11")
    (COND
       [(AND (LISTP NAME)
             (NULL TYPE))
        (MAPCAR NAME (FUNCTION (LAMBDA (I)
                                 (SAVEDEF I 'FNS]
       (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME)))
                        (/PUT NAME [SETQ TYPE (COND
                                                 ((SUBRP DEFINITION)
                                                  'SUBR)
                                                 ((EXPRP DEFINITION)
                                                  'EXPR)
                                                 ((CCODEP DEFINITION)
                                                  'CODE)
                                                 (T 'LIST]
                              DEFINITION)))
              (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME)))
                              'NOBIND)
                         (EQ DEFINITION (GETTOPVAL NAME))
                         (/PUT NAME (SETQ TYPE 'VALUE)
                               DEFINITION)))
              (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT
                                                          '(NOCOPY NOERROR NODWIM]
                   (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS))
                                                  (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME))
                                                                             SAVEDDEFS]
          TYPE])

(UNSAVEDEF
  [LAMBDA (NAME TYPE DEF)                                (* lmm " 6-Jun-86 17:24")
    (SELECTQ TYPE
        ((NIL EXPR CODE SUBR LIST) 
             (COND
                [(LISTP NAME)                                (* ; "for compatibility")
                 (MAPCAR NAME (FUNCTION (LAMBDA (X)
                                          (UNSAVED1 X TYPE]
                (T (UNSAVED1 NAME TYPE))))
        (PROG NIL
              [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
                                       'SAVED 0))
                  (RETURN (CONS TYPE '(not found]
              (COND
                 ((NEQ DFNFLG T)
                  (SAVEDEF NAME TYPE)
                  (LET ((DFNFLG T))
                       (PUTDEF NAME TYPE DEF)))
                 (T (PUTDEF NAME TYPE DEF)))
              (RETURN TYPE])

(COMPAREDEFS
  [LAMBDA (NAME TYPE SOURCES)                            (* lmm " 4-Jul-85 14:37")
    (COND
       ((AND (LISTP TYPE)
             (GETFILEPKGTYPE SOURCES NIL T))
        (swap TYPE SOURCES)))
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T]
          [COND
             ((NULL SOURCES)
              (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE))
                       (SOME SRCS (FUNCTION (LAMBDA (FILE)
                                              (MEMBER NAME (CDR (ASSOC TYPE
                                                                       (fetch TOBEDUMPED
                                                                          of (fetch FILEPROP
                                                                                    of FILE]
                   (push SRCS 'CURRENT]
          (SETQ SRCS (for SRC in SRCS
                        when (COND
                                    ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
                                          (fetch NULLDEF of TYPE))
                                     (OR [SOME DEFS (FUNCTION (LAMBDA (DP)
                                                                (COMPARELST DEF (CDR DP]
                                         (push DEFS (CONS SRC DEF)))
                                     T)
                                    (T (PRINTOUT T "No " SRC " definition found for " NAME T)
                                       NIL)) collect SRC))
          (RETURN (COND
                     ((NULL SRCS)
                      '(no definitions found))
                     ((NULL (CDR SRCS))
                      '(only one definition found))
                     ((CDR DEFS)
                      [for S1 on (DREVERSE DEFS)
                         do (for S2 on (CDR S1) do (PRIN2 NAME T T)
                                                                  (AND (CAAR S1)
                                                                       (PRIN1 " from " T)
                                                                       (PRIN2 (CAAR S1)
                                                                              T T))
                                                                  (PRIN1 " and " T)
                                                                  (PRIN2 NAME T T)
                                                                  (COND
                                                                     ((CAAR S2)
                                                                      (PRIN1 " from " T)
                                                                      (PRIN2 (CAAR S2)
                                                                             T T)))
                                                                  (PRIN1 " differ:" T)
                                                                  (TERPRI T)
                                                                  (COMPARELISTS (CDAR S1)
                                                                         (CDAR S2]
                      'DIFFERENT)
                     (T 'SAME])

(COMPARE
  [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2)             (* lmm " 5-SEP-78 13:37")
    (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY]
           (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY]
          (COND
             ((COMPARELST DEF1 DEF2)
              (RETURN)))
          (PRIN2 NAME1 T T)
          (COND
             (SOURCE1 (PRIN1 " from " T)
                    (PRIN2 SOURCE1 T T)))
          (PRIN1 " and " T)
          (PRIN2 NAME2 T T)
          (COND
             (SOURCE2 (PRIN1 " from " T)
                    (PRIN2 SOURCE2 T T)))
          (PRIN1 " differ:" T)
          (TERPRI T)
          (COMPARELISTS DEF1 DEF2)
          (RETURN T])

(TYPESOF
  [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER)
                                                          (* ; "Edited  2-Aug-88 02:08 by masinter")

    (* ;; "return list of all known types which NAME names")

    (LET
     (FOUND SHADOWED)
     (if (FMEMB SOURCE '(? NIL))
         then (CL:FLET [(RSHADOW NIL (for X in FOUND
                                            do (for Y in (CDR (FASSOC X SHADOW-TYPES))
                                                      do (if (FMEMB Y FOUND)
                                                                 then 
                                                             (* ; "shadower found before shadowed")
                                                                       (SETQ FOUND (REMOVE Y FOUND]
                         (LET (NOTFOUND NEWTYPES)
                              (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                                 when [AND (LITATOM TYPE)
                                               (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                               (OR (NULL FILTER)
                                                   (CL:FUNCALL FILTER TYPE))
                                               (NOT (find X in FOUND
                                                       suchthat (FMEMB TYPE
                                                                           (CDR (FASSOC X 
                                                                                       SHADOW-TYPES]
                                 do (if [OR (HASDEF NAME TYPE 'CURRENT)
                                                    (AND (LITATOM NAME)
                                                         (HASDEF NAME TYPE 'SAVED]
                                            then (push FOUND TYPE)
                                          else (push NOTFOUND TYPE)))
                              (RSHADOW)
                              [for FILE in FILELST while NOTFOUND
                                 when [NEQ T (fetch LOADTYPE of (GETPROP FILE
                                                                                   'FILE]
                                 do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND
                                                                      (FILECOMS FILE)
                                                                      'TYPESOF))
                                            then [bind X for TYPE in NEWTYPES
                                                        when (FMEMB TYPE NOTFOUND)
                                                        do (push FOUND TYPE)
                                                              (if (SETQ X (FASSOC TYPE 
                                                                                     SHADOW-TYPES))
                                                                  then (SETQ NOTFOUND
                                                                            (LDIFFERENCE NOTFOUND X))
                                                                else (SETQ NOTFOUND
                                                                          (REMOVE TYPE NOTFOUND]
                                                  (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES]
                              (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF))
                                  then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND))
                                        (SETQ FOUND (UNION NEWTYPES FOUND)))
                              (RSHADOW)
                              FOUND))
       else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                   when (AND (LITATOM TYPE)
                                 (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                 (OR (NULL FILTER)
                                     (CL:FUNCALL FILTER TYPE))
                                 (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE)))
     FOUND])
)

(RPAQ? WHEREIS.HASH )



(* ; "Must come after PUTDEF")

(DEFINEQ

(FIXEDITDATE
  [LAMBDA (EXPR)                                         (* ; "Edited 17-Jul-89 11:13 by jtm:")
                                                             (* NOBIND "18-JUL-78 21:11")
                                                             (* Inserts or replaces previous edit 
                                                           date)
    (AND INITIALS (LISTP EXPR)
         (LISTP (CDR EXPR))
         (PROG (E)
               (COND
                  ((FMEMB (CAR EXPR)
                          LAMBDASPLST)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR)))
                  [(FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-ARGLIST-DEFINERS)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR))
                   (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
                      finally (SETQ E (CDR E]
                  ((FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-NAME-DEFINERS)

                   (* ;; "insert the edit date after the name")

                   (SETQ E (CDDR EXPR)))
                  (T (RETURN)))
           RETRY
               [COND
                  ((NLISTP E)
                   (RETURN))
                  ((LISTP (CAR E))
                   (SELECTQ (CAAR E)
                       ((CLISP%: DECLARE) 
                            (SETQ E (CDR E))
                            (GO RETRY))
                       (BREAK1 (COND
                                  ((EQ (CAR (CADAR E))
                                       'PROGN)
                                   (SETQ E (CDR (CADAR E)))
                                   (GO RETRY))))
                       (ADV-PROG                             (* No easy way to mark cleanly the 
                                                           date of an advised function)
                                 (RETURN))
                       (COND
                          ((AND (EQ (CAAR E)
                                    COMMENTFLG)
                                (EQ (CADAR E)
                                    'DECLARATIONS%:))
                           (SETQ E (CDR E))
                           (GO RETRY]
               (COND
                  ([for TAIL on E while (AND (LISTP (CAR TAIL))
                                                         (EQ (CAAR TAIL)
                                                             COMMENTFLG))
                      do (COND
                                ((AND (LISTP (CDR TAIL))
                                      (EDITDATE? (CAR TAIL)))
                                 (/RPLACA TAIL (EDITDATE (CAR TAIL)
                                                      INITIALS))
                                 (RETURN T]                  (* scans the comments for a 
                                                           timestamp for this user.)
                   NIL)
                  (T                                         (* attach the new timestamp at the 
                                                           beginning of the comments.)
                     (/ATTACH (EDITDATE NIL INITIALS)
                            E)))
               (RETURN EXPR])

(EDITDATE?
  [LAMBDA (COMMENT)                                      (* ; "Edited 11-Jun-92 16:44 by cat")
                                                             (* ; "Edited 13-Jul-89 09:30 by jtm:")
                                                             (* lmm "21-Mar-85 08:45")

         (* Tests to see if a given common is in fact an edit date --
       this has to be general enough to recognize the most comment comment forms while 
       specific enough to not recognize things that are not edit dates)

    (DECLARE (LOCALVARS . T))                            (* jtm%: changed test so that it 
                                                           creates one timestamp per user.)
    (COND
       [(LISTP COMMENT)
        (COND
           ((EQ (CAR COMMENT)
                COMMENTFLG)
            [COND
               (NIL (NULL NORMALCOMMENTSFLG)
                    (SETQ COMMENT (GETCOMMENT COMMENT]
            (COND
               ([OR (NOT (LISTP (CDR COMMENT)))
                    (NOT (LISTP (CDDR COMMENT]
                NIL)
               [(EQ (CADR COMMENT)
                    ';)                                      (* ; "CL style comment")
                (STRPOS INITIALS (CADDR COMMENT)
                       (IMINUS (NCHARS INITIALS]
               (T                                            (* ; "IL style comment")
                  (EQ (CADR COMMENT)
                      INITIALS]
       ((STRINGP COMMENT])
)



(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")


(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))

(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
)



(* ;; 
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
)

(DEFINEQ

(FILEPKGCOM
  [LAMBDA N                                              (* JonL "10-Jul-84 19:38")
    (PROG (TEM (COM (ARG N 1)))
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in '(MACRO CONTENTS DELETE ADD)
                             when (SETQ TEM (FILEPKGCOM COM FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                               (LIST 'COM T))
                          (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                               (LIST 'COM TEM]
                     ((EQ N 2)
                      (SELECTQ (ARG N 2)
                          (ADD (fetch ADD of COM))
                          (DELETE (fetch DELETE of COM))
                          (MACRO (fetch MACRO of COM))
                          ((CONTENTS CONTAIN) 
                               [OR (fetch (FILEPKGCOM CONTENTS) of COM)
                                   (COND
                                      ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM))
                                       (COND
                                          ((EQ COM 'NILL)
                                           COM)
                                          [(EQ (CAR COM)
                                               'LAMBDA)
                                           (CONS (CAR COM)
                                                 (CONS [CONS (CAADR COM)
                                                             (CONS (OR (CADDR (CADR COM))
                                                                       'NAME)
                                                                   (CONS (CADR (CADR COM))
                                                                         (CDDDR (CADR COM]
                                                       (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM]
                                          (T (LIST 'LAMBDA '(COM TYPE NAME)
                                                   (CONS COM '(COM TYPE NAME])
                          (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                        T)
                                   (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST])
                          (ERROR (ARG N 2)
                                 "not file package command property")))
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'COM)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                (/SETTOPVAL 'FILEPKGCOMSPLST
                                                       (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST])
                                         (COND
                                            ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGCOMSPLST
                                                      (CONS (CONS COM TEM)
                                                            (GETTOPVAL 'FILEPKGCOMSPLST]
                                    (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                    (/SETTOPVAL 'FILEPKGCOMSPLST
                                                           (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                       (SELECTQ (ARG N I)
                                           (ADD (/replace (FILEPKGCOM ADD) of COM
                                                   with TEM))
                                           (DELETE (/replace (FILEPKGCOM DELETE) of
                                                                                         COM
                                                      with TEM))
                                           (MACRO (/replace (FILEPKGCOM MACRO) of COM
                                                     with TEM))
                                           ((CONTENTS CONTAIN) 
                                                (/replace (FILEPKGCOM CONTENTS) of COM
                                                   with TEM))
                                           (ERROR (ARG N I)
                                                  "not file package command property"]
                        (MARKASCHANGED COM 'FILEPKGCOMS])

(FILEPKGTYPE
  [LAMBDA N                                              (* lmm " 5-Jul-85 09:07")
    (PROG ((TYPE (ARG N 1))
           TEM)
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in (UNION '(DESCRIPTION)
                                                       FILEPKGTYPEPROPS)
                             when (SETQ TEM (FILEPKGTYPE TYPE FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                               (LIST 'TYPE T))
                          (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]
                               (LIST 'TYPE TEM]
                     [(EQ N 2)
                      (if (FMEMB (ARG N 2)
                                     FILEPKGTYPEPROPS)
                          then (GETPROP TYPE (ARG N 2))
                        else (SELECTQ (ARG N 2)
                                     (DESCRIPTION (fetch DESCRIPTION of TYPE))
                                     (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                                                    T)
                                               (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES])
                                     (ERROR (ARG N 2)
                                            "not file package type property"]
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'TYPE)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T (OR (FMEMB TYPE FILEPKGTYPES)
                                                (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES))))
                                         (COND
                                            ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES))
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM)
                                                                               FILEPKGTYPES]
                                    (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES)
                                                    (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES
                                                                                    ]
                                       (if (FMEMB (ARG N I)
                                                      FILEPKGTYPEPROPS)
                                           then (if TEM
                                                        then (/PUTPROP TYPE (ARG N I)
                                                                        TEM)
                                                      else (/REMPROP TYPE (ARG N I)))
                                         else (SELECTQ (ARG N I)
                                                      (DESCRIPTION (/replace DESCRIPTION
                                                                      of TYPE with TEM))
                                                      (ERROR (ARG N I)
                                                             "not file package command/type property"
                                                             ]
                        (MARKASCHANGED TYPE 'FILEPKGCOMS])
)

(PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS)))

(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)

(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE)
                                                                       (* Revert to NILL when no 
                                                                          longer coercing 
                                                                          PRETTYDEFMACROS to 
                                                                          FILEPKGCOMS)
                                                                       (AND (EQ TYPE 'FILEPKGCOMS)
                                                                            (INFILECOMTAIL COM]
                                                  (TYPE DESCRIPTION "file package commands/types" 
                                                        GETDEF T PUTDEF FILEPKGCOMS.PUTDEF)))
(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X]
                                             (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF 
                                                   WHENCHANGED (ALISTS.WHENCHANGED))))
(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X])
(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS)))
(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED (
                                                                              EXPRESSIONS.WHENCHANGED
                                                                                               )
                                                        EDITDEF NILL)))
(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL)))
(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)
                                                   (TYPE TYPE FILEPKGCOMS)))
(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X]
                                                 CONTENTS
                                                 (LAMBDA (COM NAME TYPE)
                                                        (AND (EQ TYPE 'FILES)
                                                             (SUBSET (INFILECOMTAIL COM)
                                                                    (FUNCTION LITATOM]
                                            (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED)
                                                  EDITDEF EDITDEF.FILES)))
(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X)))
                                               (TYPE NULLDEF NOBIND EDITDEF NILL)))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (FN)
                                                                         (AND (GETPROP FN
                                                                                     'FUNCTIONS)
                                                                              (CL:WARN 
                                                                      "~A has a FUNCTIONS definition"
                                                                                     FN]
                                                  (ORIGINAL (FNS . X)))
                                               CONTENTS NILL)
                                          (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF
                                                T)))
(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X)))
                                                       CONTENTS
                                                       (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                              (AND (NULL ONFILETYPE)
                                                                   (EQ TYPE 'RECORDS)
                                                                   (INFILECOMTAIL COM])
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS)))
(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X)))
                                                       CONTENTS NILL)
                                                  (TYPE DESCRIPTION "LISPX commands")))
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM
                                              MACRO
                                              [X
                                               (DECLARE%:
                                                EVAL@COMPILE
                                                (P
                                                 *
                                                 (MAPCAR
                                                  'X
                                                  (FUNCTION
                                                   (LAMBDA (Y)
                                                          (LET [[FNDEF (GETDEF Y 'FUNCTIONS
                                                                              'CURRENT
                                                                              '(NOCOPY NOERROR]
                                                                (MACDEF (GETDEF Y 'MACROS
                                                                               'CURRENT
                                                                               '(NOCOPY NOERROR]
                                                               (COND
                                                                ((AND FNDEF (EQ (CAR FNDEF)
                                                                                'DEFMACRO))
                                                                 (CL:WARN 
                           "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S."
                                                                        FNDEF)
                                                                 (LIST 'PROGN FNDEF MACDEF))
                                                                (T (OR MACDEF (CL:CERROR 
                                                          "Go ahead and finish writing out the file."
                                                                                     
                                                                       "No MACROS definition for ~A."
                                                                                     Y)
                                                                       (GETDEF Y 'MACROS 'CURRENT]
                                              CONTENTS NILL)
                                             (TYPE DESCRIPTION "Interlisp macros" GETDEF 
                                                   MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY))))
(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)))
(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X]
                                            (TYPE DESCRIPTION "property lists" WHENCHANGED (
                                                                                    PROPS.WHENCHANGED
                                                                                            ))))
(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM
                                               MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (RECORD)
                                                                         (AND (GETPROP RECORD
                                                                                     'STRUCTURES)
                                                                              (CL:WARN 
                                                                     "~A has a STRUCTURES definition"
                                                                                     RECORD]
                                                  (E (RECORDECLARATIONS . X))
                                                  (INITRECORDS . X))
                                               CONTENTS
                                               (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                      (AND (EQ TYPE 'FIELDS)
                                                           (NULL ONFILETYPE)
                                                           (MAPCONC (INFILECOMTAIL COM)
                                                                  (FUNCTION (LAMBDA
                                                                             (X)
                                                                             (APPEND (
                                                                                     RECORDFIELDNAMES
                                                                                      X]
                                              (TYPE DESCRIPTION "records" DELDEF
                                                    (LAMBDA (X)
                                                           (/SETTOPVAL 'USERRECLST
                                                                  (REMOVE (RECLOOK X)
                                                                         USERRECLST])
(PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X)))
                                                      CONTENTS
                                                      (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                             (AND (NULL ONFILETYPE)
                                                                  (EQ TYPE 'RECORDS)
                                                                  (INFILECOMTAIL COM])
(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X)))
                                                      CONTENTS NILL)
                                                 (TYPE DESCRIPTION "edit macros")))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                                (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                          (VAR)
                                                                          (AND (GETPROP VAR
                                                                                      'VARIABLES)
                                                                               (CL:WARN 
                                                                 "~A also has a VARIABLES definition"
                                                                                      VAR]
                                                   (ORIGINAL (VARS . X)))
                                                CONTENTS NILL)
                                           (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF 
                                                 VARS.PUTDEF)))
(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL)))
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X)
                                                                     (P (CONSTANTS . X])

(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
                           (VARIABLES VARS CONSTANTS))

(RPAQ? SAVEDDEFS )



(* ; "EDITCALLERS")

(DEFINEQ

(FINDCALLERS
  [LAMBDA (ATOMS FILES)                                  (* lmm "30-SEP-78 01:36")
    (PROG ((X (EDITCALLERS ATOMS FILES T)))
          (RETURN (NCONC (DREVERSE (CDR X))
                         (AND (CAR X)
                              (LIST (CONS (COND
                                             ((CDR X)
                                              '"plus other places on")
                                             (T 'on))
                                          (CAR X])

(EDITCALLERS
  [LAMBDA (ATOMS FILES COMS)                            (* ; "Edited  8-Aug-2020 17:32 by rmk:")
                                                             (* bvm%: " 3-Nov-86 17:30")
    (LET
     (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN)
     [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS]
     [for FILE in (COND
                             ((NULL FILES)
                              FILELST)
                             ((EQ FILES T)
                              (UNION SYSFILES FILELST))
                             ((LISTP FILES)
                              FILES)
                             (T (LIST FILES)))
        do
        (RESETLST
            [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I)
                  (OR (SETQ FULL (FINDFILE FILE))
                      (RETURN (LISPXPRINT (CONS FILE '(not found))
                                     T T)))
                  [RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                       (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT]
                  (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM)))
                  (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP)
                         (OR (GET-ENVIRONMENT-AND-FILEMAP FULL)
                             (\PARSE-FILE-HEADER FILESTREAM)))

             (* ;; "Get reader environment of file.  The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists.  Otherwise, read the top of the file")

                  (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV)))
                  (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL))
                  [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS)))
                      (push FFILEPOSPATTERNS
                             (CONS RDTBL (SETQ PATTERNS
                                          (for ATOM in ATOMS
                                             collect (CONCAT
                                                          (COND
                                                             ((EQ (CHCON1 ATOM)
                                                                  (CHARCODE ESCAPE))
                                                              (SETQ ATOM (SUBSTRING ATOM 2 -1))
                                                              "")
                                                             (T " "))
                                                          [COND
                                                             ((SETQ I (STRPOS ' ATOM))
                                                              (SUBSTRING ATOM 1 (SUB1 I)))
                                                             ((STRINGP ATOM))
                                                             (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE
                                                                                  ATOM)))
                                                             (* ; 
                                                           "Keep MKSTRING from putting a prefix on")
                                                                     (MKSTRING ATOM T RDTBL]
                                                          (COND
                                                             (I "")
                                                             (T " "]
                  (for PATTERN in PATTERNS
                     do
                     (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0)))
                     (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA))
                        do
                        (COND
                           ((NULL PRINTFLG)                  (* ; 
                                   "cause the printing of the filename to be saved on history list")
                            (SETQ PRINTFLG T)
                            (LISPXPRIN2 FULL T T T)

                            (* ;; "print with NODOFLG=T means just to record the printing;  the idea is that only those files in which something is found will be remembered on the history list")

                            (LISPXPRIN1 ": " T NIL T)))
                        [OR
                         [AND (NEQ MAP T)
                              (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0)
                                                                    (SETQ MAP (OR (GETFILEMAP 
                                                                                         FILESTREAM)
                                                                                  (LOADFILEMAP 
                                                                                         FILESTREAM]
                                                         (PROGN 
                                                             (* ; "file has no filemap")
                                                                (SETQ MAP (SETQ NOMAPFLG T))
                                                                (LISPXPRIN1 " no filemap!" T)
                                                                NIL)))
                                 thereis (AND (ILESSP (CAR X)
                                                         I)
                                                  (IGREATERP (CADR X)
                                                         I)
                                                  (for Z in (CDDR X)
                                                     thereis (COND
                                                                    ((AND (ILESSP (CADR Z)
                                                                                 I)
                                                                          (IGREATERP (CDDR Z)
                                                                                 I))
                                                                     [COND
                                                                        ((NOT (FMEMB (CAR Z)
                                                                                     FNS))
                                                                         (SETQ FNS
                                                                          (CONS (LISPXPRIN2
                                                                                 (CAR Z)
                                                                                 T T)
                                                                                FNS]
                                                                     (SETQ I (CDDR Z))
                                                                     T]
                         (PROGN (LISPXPRIN2 I T T)
                                (OR (FMEMB FILE OTHERSFILES)
                                    (SETQ OTHERSFILES (CONS FILE OTHERSFILES]
                        (LISPXSPACES 1 T)))
                  (COND
                     (PRINTFLG (LISPXTERPRI T))
                     (T (TERPRI T)))
                  (COND
                     ((NEQ COMS T)
                      (COND
                         ((OR FNS OTHERSFILES)
                          (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS))
                                 FULL EDITPATTERN COMS (NULL OTHERSFILES))
                          (SETQ OTHERSFILES)
                          (SETQ FNS])]
     (COND
        ((EQ COMS T)
         (CONS OTHERSFILES FNS])

(EDITFROMFILE
  [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES)     (* rmk%: "14-Mar-85 21:51")
    (RESETVARS [(EDITLOADFNSFLG (COND
                                   ((EQ EDITLOADFNSFLG T)
                                    '(T . NO))
                                   (T EDITLOADFNSFLG]
               (PROG NIL
                     [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN]
                     (AND
                      (SETQ FILES (for FILE inside (OR FILES FILELST)
                                     when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE)
                                                                             FILELST))
                                                  (COND
                                                     ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" 
                                                                                        FILE)
                                                                    NIL T))
                                                      (LOADFROM FILE FNS 'ALLPROP)
                                                      T))) collect FILE))
                      (for TYPE in [COND
                                              ((LISTP ONLYTYPES))
                                              (ONLYTYPES '(FNS))
                                              (T 

                                 (* ;; "Move FNS to the front.  This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.")

                                                 (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES]
                         when (AND (LITATOM TYPE)
                                       (NEQ (fetch EDITDEF of TYPE)
                                            'NILL))
                         do
                         (PROG (SEEN)
                               (for FILE inside FILES
                                  do
                                  (for NAME in [COND
                                                          ((AND (EQ TYPE 'FNS)
                                                                (NEQ FNS T))
                                                             (* ; 
                                                    "for this type, we are given the list of items")
                                                           (PROG1 FNS (SETQ FNS NIL)))
                                                          (T (* ; 
                             "only want the values of `TYPE' which are not part of some other type")
                                                             (FILECOMSLST FILE TYPE 'EDIT]
                                     unless (MEMBER NAME SEEN)
                                     do
                                     (ERSETQ
                                      (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT
                                                             '(NOCOPY NOERROR))
                                                      (GETDEF NAME TYPE 'SAVED
                                                             '(NOCOPY NOERROR]

                                 (* ;; "If definition has been loaded, it may have been editted.  Work on that explicitly instead of bringing in a file definition to smash the users previous changes.  Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS.  --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file.  But ...  rmk")

                                            (COND
                                               ((OR (AND (EQ TYPE 'FNS)
                                                         (NEQ FNS T))
                                                    (AND (LISTP DEF)
                                                         (LOOKIN DEF EDITPATTERN)))
                                                (COND
                                                   ((NULL SEEN)
                                                    (LISPXPRIN1 "editing the " T)
                                                    (LISPXPRIN1 (OR (fetch DESCRIPTION
                                                                       of TYPE)
                                                                    TYPE)
                                                           T)
                                                    (LISPXSPACES 1 T)))
                                                (SETQ SEEN (CONS NAME SEEN))
                                                (LISPXPRIN2 NAME T T)
                                                (LISPXPRIN1 ":
" T)
                                                (COND
                                                   ((NOT
                                                     (ERSETQ (EDITDEF
                                                              NAME TYPE
                                                              (OR (AND DEF (CONS '= DEF))
                                                                  FILE)
                                                              EDITCOMS)))
                                                    (LISPXPRIN1 "failed" T)))
                                                (LISPXTERPRI T])

(FINDATS
  [LAMBDA (X L)                                          (* lmm "11-FEB-78 16:03")
    (COND
       ((NLISTP X)
        (FMEMB X L))
       (T (OR (FINDATS (CAR X)
                     L)
              (FINDATS (CDR X)
                     L])

(LOOKIN
  [LAMBDA (X PAT)                                        (* lmm "11-MAR-78 14:20")
    (COND
       ([AND (EQ (CAR PAT)
                 '*ANY*)
             (EVERY (CDR PAT)
                    (FUNCTION (LAMBDA (X)
                                (AND (LITATOM X)
                                     (NOT (STRPOS ' X]
        (FINDATS X (CDR PAT)))
       (T (EDITFINDP X PAT T])
)
(DEFINEQ

(SEPRCASE
  [LAMBDA (CLFLG RDTBL)                                  (* bvm%: "24-Oct-86 18:16")

    (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent.  Based on FILERDTBL, but others are close with respect to breaks and seprs")

    (OR RDTBL (SETQ RDTBL FILERDTBL))
    (OR [ARRAYP (CDR (ASSOC RDTBL (COND
                                     (CLFLG CLISPCASEARRAYS)
                                     (T SEPRCASEARRAYS]
        (LET ((CA (CASEARRAY)))
             [if (READTABLEPROP RDTBL 'CASEINSENSITIVE)
                 then                                    (* ; "map upper into lower case")
                       (for I from (CHARCODE A) to (CHARCODE Z)
                          do (SETCASEARRAY CA I (+ I (- (CHARCODE a)
                                                            (CHARCODE A]
             (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS
                                                    collect (CHCON1 Y)))
                                      (GETSEPR RDTBL)
                                      (GETBRK RDTBL)) do (SETCASEARRAY CA X 0))
             (if *PACKAGE*
                 then                                    (* ; 
                               "symbols qualified with package prefix will otherwise be unfindable")
                       (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR)
                              0))
             (SETQ CA (CONS RDTBL CA))
             (COND
                (CLFLG (push CLISPCASEARRAYS CA))
                (T (push SEPRCASEARRAYS CA)))
             (CDR CA])
)

(RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL))

(RPAQ? SEPRCASEARRAYS )

(RPAQ? CLISPCASEARRAYS )

(MOVD? 'INFILEP 'FINDFILE)

                                                             (* ; "or else from SPELLFILE")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
       (NOLINKFNS LOADFROM))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)
)



(* ; "EXPORT")

(DEFINEQ

(IMPORTFILE
  [LAMBDA (FILE RETURNFLG)                               (* lmm " 6-Jun-86 17:43")
    (RESETLST
        [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT]
        (RESETSAVE (INPUT FILE))                             (* ; 
                "Reset INPUT in case some form on the file's action is to read the next expression")
        (NCONC [COND
                  ((EQ RETURNFLG T)                          (* ; 
                                           "Just creating EXPORTS.ALL, don't side-effect the world")
                   (IMPORTFILESCAN FILE RETURNFLG))
                  (T (LET (FILEPKGFLG DFNFLG)
                          (IMPORTFILESCAN FILE RETURNFLG]
               (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE))
                                     ''IMPORTDATE
                                     (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE]
                      RETURNFLG)))])

(IMPORTEVAL
  [LAMBDA (FORM RETURNFLG)                               (* ; "Edited  2-May-87 18:57 by Pavel")

    (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")

    (AND (LISTP FORM)
         (SELECTQ (CAR FORM)
             (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (/DECLAREDATATYPE                               (* ; 
                    "Ignore datatype initializations -- we only need the record declaration itself")
                  NIL)
             (PROGN                                          (* ; "default: eval and/or return it")
                    (AND (NEQ RETURNFLG T)
                         (EVAL FORM))
                    (AND RETURNFLG (LIST FORM])

(IMPORTFILESCAN
  [LAMBDA (FILE RETURNFLG)                               (* bvm%: "24-Oct-86 19:31")
    (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
        (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
           join (until (EQUAL (SETQ DEF (READ FILE))
                                      ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])

(CHECKIMPORTS
  [LAMBDA (FILES NOASKFLG)                               (* rmk%: "19-FEB-83 16:31")
                                                             (* ; 
                                           "Loads exported definitions from new versions of FILES.")
    (COND
       ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE
                            when [AND (SETQ FULLFILENAME (FINDFILE FILE T))
                                          (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE)
                                                                     'IMPORTDATE]
                                              (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 
                                                                     'ICREATIONDATE]
                            collect (LIST FILE FULLFILENAME)))
             (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from "
                                                       (MAPCAR FILES (FUNCTION CAR)))
                                          '((Y "es
")
                                            (N "o
"))
                                          T)
                              (N NIL)
                              T)))
        (for FILE in FILES do (IMPORTFILE (CADR FILE])

(GATHEREXPORTS
  [LAMBDA (FROMFILES TOFILE FLG)                         (* bvm%: "14-Oct-86 23:12")
                                                             (* ; 
                                        "Copies all exported definitions from FROMFILES to TOFILE.")
    (RESETLST
        [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE)
                             (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT]
        (RESETSAVE (OUTPUT TOFILE))
        (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*))
             (SETQ ENV (if ENV
                           then (\DO-DEFINE-FILE-INFO NIL ENV)
                         else *OLD-INTERLISP-READ-ENVIRONMENT*))
             (WITH-READER-ENVIRONMENT ENV
                 (PRINT-READER-ENVIRONMENT ENV)
                 (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T)
                        " ON "
                        (DATE)
                        "%"  T)" T "(LISPXTERPRI T)" T)
                 (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T))
                                                              (FUNCTION PRINT))
                                                       (TERPRI))
                 (PRINT 'STOP)
                 (TERPRI)
                 (FULLNAME TOFILE))))])

(\DUMPEXPORTS
  [NLAMBDA COMS                                          (* bvm%: "24-Oct-86 19:42")

(* ;;; "Dumps an EXPORT form.  IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.")

    (PRIN1 "(")
    (PRIN2 '*)
    (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2))               (* ; 
                                   "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE")
    (for TAIL on COMS do (PRETTYCOM (CAR TAIL)))
    (TERPRI)
    (PRINT ENDEXPORTDEFFORM)
    (TERPRI])
)
(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X])

(RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")

(RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)
)



(* ; "for GAINSPACE")

(DEFINEQ

(CLEARFILEPKG
  [LAMBDA (FLG)                                          (* bvm%: "29-Aug-86 13:02")
    (PROG NIL
          (COND
             ((SELECTQ FLG
                  ((E T) 
                       T)
                  (Y (TERPRI T)
                     (PRIN1 "you can delete just the filemaps -
" T)
                     (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? "
                                   '((Y "es - everything" RETURN T)
                                     (N "o - just the filemaps" RETURN NIL)
                                     (E "verything" RETURN T)
                                     (F "ilemaps only" RETURN NIL]
                            (TERPRI T)))
                  NIL)
              (UPDATEFILES)
              [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE)
                                                        (COND
                                                           ((fetch TOBEDUMPED
                                                               of (fetch FILEPROP
                                                                         of FILE))
                                                            (PRINT FILE T T)
                                                            (PRIN1 " has changes, not wiped." T)
                                                            (TERPRI T)
                                                            T)
                                                           (T (replace FILEPROP of FILE
                                                                 with NIL)
                                                              (replace FILECHANGES of FILE
                                                                 with NIL)
                                                              (SMASHFILECOMS FILE)
                                                              (NCONC1 SYSFILES FILE)
                                                              NIL]
              (SETQ LOADEDFILELST)))
          (SELECTQ FLG
              ((NIL T))
              (CLRHASH *FILEMAP-HASH*])
)

(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                    ((Y "es")
                                     (N "o")
                                     (E . "verything")
                                     (F "ilemaps only
"))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SMASHPROPSLST1)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST 
       DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS 
       LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG 
       MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS 
       FILEPKGTYPEPROPS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
       (SPECVARS COMSNAME))

(BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
       (NOLINKFNS . T)
       (SPECVARS COMSNAME)
       (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))

(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS 
       INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
       (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
       INFILECOMSPROP)

(BLOCK%: NIL MAKEFILE (LOCALVARS . T)
       (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))

(BLOCK%: ADDFILE ADDFILE ADDFILE0)

(BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))

(BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
       COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF 
       EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE
       FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES 
       MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED 
       MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
       SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF 
       UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS 
                          EDITLOADFNSFLG LOADOPTIONS)
       (LOCALVARS . T))

(BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))

(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
       GETDEFSAVED (RETFNS GETDEFCOM)
       (NOLINKFNS . T)
       (GLOBALVARS NOT-FOUNDTAG))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS 
                          MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS 
                          PRETTYDEFMACROS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1995 2018 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (22882 24587 (SEARCHPRETTYTYPELST 22892 . 23871) (PRETTYDEFMACROS 23873 . 24331) (
FILEPKGCOMPROPS 24333 . 24585)) (25389 59512 (CLEANUP 25399 . 26787) (COMPILEFILES 26789 . 27065) (
COMPILEFILES0 27067 . 27787) (CONTINUEDIT 27789 . 29209) (MAKEFILE 29211 . 40853) (FILECHANGES 40855
 . 43190) (FILEPKG.MERGECHANGES 43192 . 44015) (FILEPKG.CHANGEDFNS 44017 . 44329) (MAKEFILE1 44331 . 
48558) (COMPILE-FILE? 48560 . 50117) (MAKEFILES 50119 . 51812) (ADDFILE 51814 . 54335) (ADDFILE0 54337
 . 58473) (LISTFILES 58475 . 59510)) (60200 95440 (FILEPKGCHANGES 60210 . 61560) (GETFILEPKGTYPE 61562
 . 64635) (MARKASCHANGED 64637 . 66274) (FILECOMS 66276 . 66660) (WHEREIS 66662 . 68082) (
SMASHFILECOMS 68084 . 68319) (FILEFNSLST 68321 . 68483) (FILECOMSLST 68485 . 68969) (UPDATEFILES 68971
 . 74271) (INFILECOMS? 74273 . 76176) (INFILECOMTAIL 76178 . 77318) (INFILECOMS 77320 . 77481) (
INFILECOM 77483 . 87692) (INFILECOMSVALS 87694 . 88021) (INFILECOMSVAL 88023 . 89025) (INFILECOMSPROP 
89027 . 89856) (IFCPROPS 89858 . 91119) (IFCEXPRTYPE 91121 . 91632) (IFCPROPSCAN 91634 . 92687) (
IFCDECLARE 92689 . 94000) (INFILEPAIRS 94002 . 94334) (INFILECOMSMACRO 94336 . 95438)) (95475 126251 (
FILES? 95485 . 97678) (FILES?1 97680 . 98330) (FILES?PRINTLST 98332 . 99114) (ADDTOFILES? 99116 . 
109718) (ADDTOFILE 109720 . 110636) (WHATIS 110638 . 112614) (ADDTOCOMS 112616 . 114260) (ADDTOCOM 
114262 . 120809) (ADDTOCOM1 120811 . 121982) (ADDNEWCOM 121984 . 123034) (MAKENEWCOM 123036 . 124879) 
(DEFAULTMAKENEWCOM 124881 . 126249)) (126321 129138 (MERGEINSERT 126331 . 128674) (MERGEINSERT1 128676
 . 129136)) (130657 141569 (DELFROMFILES 130667 . 131517) (DELFROMCOMS 131519 . 133198) (DELFROMCOM 
133200 . 139068) (DELFROMCOM1 139070 . 139867) (REMOVEITEM 139869 . 140743) (MOVETOFILE 140745 . 
141567)) (141783 144152 (SAVEPUT 141793 . 144150)) (144277 152601 (UNMARKASCHANGED 144287 . 145995) (
PREEDITFN 145997 . 148508) (POSTEDITPROPS 148510 . 151011) (POSTEDITALISTS 151013 . 152599)) (152750 
173304 (ALISTS.GETDEF 152760 . 153139) (ALISTS.WHENCHANGED 153141 . 153785) (CLEARCLISPARRAY 153787 . 
154961) (EXPRESSIONS.WHENCHANGED 154963 . 155337) (MAKEALISTCOMS 155339 . 156412) (MAKEFILESCOMS 
156414 . 157851) (MAKELISPXMACROSCOMS 157853 . 159871) (MAKEPROPSCOMS 159873 . 160571) (
MAKEUSERMACROSCOMS 160573 . 162373) (PROPS.WHENCHANGED 162375 . 162996) (FILEGETDEF.LISPXMACROS 162998
 . 164440) (FILEGETDEF.ALISTS 164442 . 165061) (FILEGETDEF.RECORDS 165063 . 165994) (FILEGETDEF.PROPS 
165996 . 166788) (FILEGETDEF.MACROS 166790 . 167850) (FILEGETDEF.VARS 167852 . 168268) (FILEGETDEF.FNS
 168270 . 169634) (FILEPKGCOMS.PUTDEF 169636 . 172076) (FILES.PUTDEF 172078 . 173035) (VARS.PUTDEF 
173037 . 173180) (FILES.WHENCHANGED 173182 . 173302)) (175326 182759 (RENAME 175336 . 176737) (
CHANGECALLERS 176739 . 182757)) (182760 230708 (SHOWDEF 182770 . 183563) (COPYDEF 183565 . 186039) (
GETDEF 186041 . 188317) (GETDEFCOM 188319 . 189285) (GETDEFCOM0 189287 . 190633) (GETDEFCURRENT 190635
 . 197055) (GETDEFERR 197057 . 198358) (GETDEFFROMFILE 198360 . 202640) (GETDEFSAVED 202642 . 203746) 
(PUTDEF 203748 . 204451) (EDITDEF 204453 . 205430) (DEFAULT.EDITDEF 205432 . 208268) (EDITDEF.FILES 
208270 . 208471) (LOADDEF 208473 . 208649) (DWIMDEF 208651 . 209505) (DELDEF 209507 . 212521) (
DELFROMLIST 212523 . 213027) (HASDEF 213029 . 219351) (GETFILEDEF 219353 . 219875) (SAVEDEF 219877 . 
221536) (UNSAVEDEF 221538 . 222434) (COMPAREDEFS 222436 . 225738) (COMPARE 225740 . 226444) (TYPESOF 
226446 . 230706)) (230775 235818 (FIXEDITDATE 230785 . 234288) (EDITDATE? 234290 . 235816)) (236237 
244823 (FILEPKGCOM 236247 . 241180) (FILEPKGTYPE 241182 . 244821)) (256860 271412 (FINDCALLERS 256870
 . 257385) (EDITCALLERS 257387 . 265045) (EDITFROMFILE 265047 . 270727) (FINDATS 270729 . 271001) (
LOOKIN 271003 . 271410)) (271413 273140 (SEPRCASE 271423 . 273138)) (273657 279199 (IMPORTFILE 273667
 . 274641) (IMPORTEVAL 274643 . 275523) (IMPORTFILESCAN 275525 . 275946) (CHECKIMPORTS 275948 . 277284
) (GATHEREXPORTS 277286 . 278609) (\DUMPEXPORTS 278611 . 279197)) (279537 281745 (CLEARFILEPKG 279547
 . 281743)))))
STOP
\ No newline at end of file
diff --git a/sources/FILEPKG.~4~ b/sources/FILEPKG.~4~
deleted file mode 100644
index 1ca197ac..00000000
--- a/sources/FILEPKG.~4~
+++ /dev/null
@@ -1,2 +0,0 @@
-

(RPAQQ ADDTOFILEKEYLST
       (("[" "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" NOECHOFLG T)
        (= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T)
        (%
- "" EXPLAINSTRING "{line-feed} - same as previous response" NOECHOFLG T)
        (" " " 
" EXPLAINSTRING "{space} - no action" NOECHOFLG T)
        ("]" "Nowhere
" EXPLAINSTRING "] - nowhere, item is marked as a dummy
" NOECHOFLG T)
        ["(" "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST (( "" CONFIRMFG
                                                                           (%) %] %  %
)
                                                                           RETURN
                                                                           (CDR ANSWER]
        '(@ "Near: " EXPLAINSTRING "@ other-item   -- put the item near the other item" NOECHOFLG T 
            KEYLST (( "" CONFIRMFLG (%
)
                       RETURN ANSWER)))
        (%
 "" RETURN % )
        ("" "File name: " EXPLAINSTRING "a file name" KEYLST ())))
\ No newline at end of file
diff --git a/sources/FILEPKG.~6~ b/sources/FILEPKG.~6~
deleted file mode 100644
index a0bfe4fb..00000000
--- a/sources/FILEPKG.~6~
+++ /dev/null
@@ -1,13 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "18-Apr-2018 10:41:28" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;6 283387 

      changes to%:  (FNS EDITCALLERS)

      previous date%: "16-Apr-2018 21:37:05" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;5)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018 by Venue & Xerox Corporation.  All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")

(PRETTYCOMPRINT FILEPKGCOMS)

(RPAQQ FILEPKGCOMS
       [(COMS                                                (* ; 
            "standard records for accessing file  package type/command parts.  Exported for PRETTY")
              (VARS FILEPKGTYPEPROPS)
              (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
              (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
              (INITRECORDS * FILEPKGRECORDS))
        [DECLARE%: EVAL@COMPILE DOCOPY 

               (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.")

               (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES 
                                       PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS
                                       PRETTYFLG))
                  (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES 
                                       NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS]
        (INITVARS (MSDATABASELST))
        [COMS 
              (* ;; "making, adding, listing, compiling files")

              (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES 
                   FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE
                   ADDFILE0 LISTFILES)
              (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
                     (FILELST)
                     (LOADEDFILELST)
                     (NOTLISTEDFILES)
                     (NOTCOMPILEDFILES)
                     (MAKEFILEFORMS)
                     (NILCOMS))
              (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% 
                              F ST STF (REC . RC)
                              (BREC . RC)
                              (TC . C)
                              (BC . C)
                              (TCOMPL . C)
                              (BCOMPL . C)))
              (INITVARS (MAKEFILEREMAKEFLG T)
                     (CLEANUPOPTIONS '(RC]
        (COMS 
              (* ;; "scanning file coms")

              (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS 
                   FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM
                   INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                   IFCDECLARE INFILEPAIRS INFILECOMSMACRO))
        (COMS 
              (* ;; "adding to a file")

              (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM 
                   ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM)
              (INITVARS (DEFAULTCOMHASFILEFLG))
              (ADDVARS (MARKASCHANGEDFNS))
              (FNS MERGEINSERT MERGEINSERT1)
              (INITVARS [ADDTOFILEKEYLST (LIST '(%[ "" EXPLAINSTRING 
                                           "[ -- prettyprint the item to terminal and then ask again"
                                                    NOECHOFLG T)
                                               (LIST (CHARACTER (CHARCODE ^J))
                                                     ""
                                                     'EXPLAINSTRING 
                                                     "{line-feed} - same as previous response"
                                                     'NOECHOFLG T)
                                               '(%  " %
-" EXPLAINSTRING "{space} - no action" 
                                                    NOECHOFLG T)
                                               '(%] "Nowhere%
-" EXPLAINSTRING 
                                                    "] - nowhere, item is marked as a dummy%
-" 
                                                    NOECHOFLG T)
                                               '[%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG
                                                    T KEYLST (( "" CONFIRMFLG (%) %] %  %
-)
                                                                 RETURN
                                                                 (CDR ANSWER]
                                               '(@ "Near: " EXPLAINSTRING 
                                                 "@ other-item   -- put the item near the other item"
                                                   NOECHOFLG T KEYLST (( "" CONFIRMFLG (%
-)
                                                                          RETURN ANSWER)))
                                               (LIST (CHARACTER (CHARCODE ^M))
                                                     ""
                                                     'RETURN
                                                     '% )
                                               '("" "File name: " EXPLAINSTRING "a file name" KEYLST
                                                    (]
                     (LASTFILE)))
        (COMS 
              (* ;; "deleting an item from a file")

              (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE)
              (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
                 (MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
              (ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
        [COMS                                                (* ; 
                      "functions for doing things and marking them changed and auxiliary functions")
              (FNS SAVEPUT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
                                                     (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
              (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
              (ADDVARS (LISPXFNS (PUT . SAVEPUT)
                              (PUTPROP . SAVEPUT]
        (COMS                                                (* ; 
                                                  "sub-functions for file package commands & types")
              (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED 
                   MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS 
                   PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS 
                   FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS 
                   FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED)
              (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO)
                     (SYSPROPS PROPTYPE))
              (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT 
                    FILETYPE)
              (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS 
                    LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS 
                    PRETTYPRINTYPEMACROS USERMACROS))
        (COMS                                                (* ; 
                    "Define the commands below AFTER the various properties have been established.")
              (USERMACROS M))
        (COMS                                                (* ; "GETDEF methods")
              (FNS RENAME CHANGECALLERS)
              (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
                   GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF 
                   DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
              (INITVARS (WHEREIS.HASH)))
                                                             (* ; "Must come after PUTDEF")
        (FNS FIXEDITDATE EDITDATE?)
                                                             (* ; 
                                  "Edit date support for all kinds of definers (from PARC 6/10/92)")
        [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
              (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
        (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
        (COMS 
              (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")

              (FNS FILEPKGCOM FILEPKGTYPE)
              (PROP ARGNAMES FILEPKGCOM)
              (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
                     (FILEPKGTYPES FILEPKGCOMS))
              (FILEPKGCOMS FILEPKGCOMS)
              (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS
                     INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS
                     OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS))
        (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS)
                        (VARIABLES VARS CONSTANTS)))
        (INITVARS (SAVEDDEFS))
        (COMS                                                (* ; "EDITCALLERS")
              (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
              (FNS SEPRCASE)
              [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL]
              (INITVARS (SEPRCASEARRAYS)
                     (CLISPCASEARRAYS))
              (P (MOVD? 'INFILEP 'FINDFILE)
                                                             (* ; "or else from SPELLFILE"))
              (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
                             (NOLINKFNS LOADFROM)))
              (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS))
        (COMS                                                (* ; "EXPORT")
              (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS)
              (FILEPKGCOMS EXPORT)
              [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
                     (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"]
              (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM))
        (COMS                                                (* ; "for GAINSPACE")
              (FNS CLEARFILEPKG)
              [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                              ((Y "es")
                                               (N "o")
                                               (E . "verything")
                                               (F "ilemaps only%
-"]
              (GLOBALVARS SMASHPROPSLST1))
        (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT 
               DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 
               I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS 
               MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS 
               SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS)
        (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
                       (SPECVARS COMSNAME))
               (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
                      (NOLINKFNS . T)
                      (SPECVARS COMSNAME)
                      (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
               (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL 
                      INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                      IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
                      INFILECOMSPROP)
               (NIL MAKEFILE (LOCALVARS . T)
                    (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
               (ADDFILE ADDFILE ADDFILE0)
               (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
               (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
                    COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES 
                    EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM 
                    FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL 
                    LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS 
                    MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE 
                    POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
                    SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED 
                    UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS 
                                                 COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
                    (LOCALVARS . T))
               (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
               (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
                      GETDEFSAVED (RETFNS GETDEFCOM)
                      (NOLINKFNS . T)
                      (GLOBALVARS NOT-FOUNDTAG)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS 
                               MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP 
                               FILEPKGCOMPROPS PRETTYDEFMACROS)
                      (NLAML)
                      (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES])



(* ; "standard records for accessing file  package type/command parts.  Exported for PRETTY")


(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF CANFILEDEF FILEGETDEF))
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(DECLARE%: EVAL@COMPILE

(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
                                               (T (/REMPROP DATUM 'PRETTYTYPE]
                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
                                  (STANDARD [COND
                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
                                                                (OR (LISTP (GETTOPVAL 
                                                                                  'PRETTYDEFMACROS))
                                                                    (SETTOPVAL 'PRETTYDEFMACROS
                                                                           (LIST (LIST DATUM]
                                               (T (SETTOPVAL 'PRETTYDEFMACROS
                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
                                                                                'PRETTYDEFMACROS))
                                                                (GETTOPVAL 'PRETTYDEFMACROS]
                                         UNDOABLE
                                         (COND
                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
                                                                        (LIST (LIST DATUM]
                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
                                                                                   'PRETTYDEFMACROS))
                                                             (GETTOPVAL 'PRETTYDEFMACROS]
                                                             (* Not an atom record cause want 
                                                           REMPROP on NILs.)
                                                             (* NOTE%: PRETTCOM on PRETTY has 
                                                           open-coded access to the MACRO 
                                                           property.)
                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
                                       FILEPKGCONTENTS)))

(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
                                                           )
                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
                                                                              DATUM)))
                                                           (STANDARD (SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                      DATUM NEWVALUE)
                                                                                     )
                                                                            NEWVALUE)
                                                                  UNDOABLE
                                                                  (/SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                    DATUM NEWVALUE))
                                                                         NEWVALUE)))
                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
                                                                             DATUM)))
                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
                                                                               DATUM NEWVALUE))
                                                                       NEWVALUE)))
                                                    (ALLFIELDS NIL (/SETTOPVAL
                                                                    'PRETTYTYPELST
                                                                    (REMOVE (SEARCHPRETTYTYPELST
                                                                             DATUM)
                                                                           (GETTOPVAL 'PRETTYTYPELST]
                                                             (* NOTE%: PRETTYCOM on PRETTY has 
                                                           open-coded access to GETDEF property)
                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                                                                   (PUT X
                                                                                        'PROPTYPE
                                                                                        'FILEPKGCOMS]
                                         (ADDTOVAR PRETTYTYPELST ))))

(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
                                                    UNDOABLE
                                                    (/PUTPROP DATUM 'FILE NEWVALUE])

(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))

(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
)

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
)

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(SEARCHPRETTYTYPELST
  [LAMBDA (TYPE FLG)                                     (* rmk%: " 3-JAN-82 22:55")
                                                             (* ; 
                                                           "access functions used by the records")
    (AND (LITATOM TYPE)
         (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X)
                                                               TYPE))
             (COND
                (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE
                                                                             'LST)
                                                                      TYPE NIL))
                                                      (GETTOPVAL 'PRETTYTYPELST]
                     (OR (LISTP (GETTOPVAL (CAR FLG)))
                         (/SETTOPVAL (CAR FLG)
                                NIL))
                     FLG])

(PRETTYDEFMACROS
  [NLAMBDA ARGS                                          (* lmm " 5-SEP-78 16:16")
                                                             (* ; 
                                                 "included so that old files will continue to load")
    (for X in ARGS collect (FILEPKGCOM (CAR X)
                                              'MACRO
                                              (CDR X])

(FILEPKGCOMPROPS
  [NLAMBDA PROPS
    (MAPC PROPS (FUNCTION (LAMBDA (Y)
                            (OR (MEMB Y SYSPROPS)
                                (SETQ SYSPROPS (CONS Y SYSPROPS)))
                            (PUT Y 'PROPTYPE 'FILEPKGCOMS])
)

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS 
                     *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG))

(CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS 
                     CLEANUPOPTIONS))
)

(RPAQ? MSDATABASELST )



(* ;; "making, adding, listing, compiling files")

(DEFINEQ

(CLEANUP
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (PROG (TEM1 TEM2 OPTIONS)
          (COND
             ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
              (SETQ OPTIONS (CAR FILES))
              (SETQ FILES (CDR FILES)))
             (T (SETQ OPTIONS CLEANUPOPTIONS)))
          (RETURN (APPEND (MAKEFILES OPTIONS FILES)
                         (COND
                            ((NOT (MEMB 'LIST OPTIONS))
                             NIL)
                            ((NULL FILES)
                             (LISTFILES))
                            ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES))
                                                             (* ; 
            "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.")
                             (APPLY 'LISTFILES TEM1)))
                         (COND
                            [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS]
                            ((NULL FILES)
                             (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES)
                                    (CDR TEM1))
                             TEM2)
                            ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES))
                             (COMPILEFILES0 TEM2 (CDR TEM1))
                             TEM2])

(COMPILEFILES
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (COND
       ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
        (COMPILEFILES0 (CDR FILES)
               (CAR FILES)))
       (T (COMPILEFILES0 FILES])

(COMPILEFILES0
  [LAMBDA (FILES OPTIONS)                                (* rmk%: "19-FEB-83 21:59")
    (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES)
       first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS))
                                (C (SETQ RCFLG NIL)
                                   (CDR OPTIONS))
                                (RC (CDR OPTIONS))
                                OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X)
                                                                           70 FILELST NIL X)
                                                                    (CAR X))
                                                        RCFLG OPTS X])

(CONTINUEDIT
  [LAMBDA (FILE)                                         (* bvm%: "30-Aug-86 15:09")
    (PROG (STREAM FL TEM FC ENV)
          (RESETLST
              [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT]
              (SETQ FILE (FULLNAME STREAM))
              (SETFILEPTR STREAM 0)
              (CL:MULTIPLE-VALUE-SETQ (ENV FC)
                     (\PARSE-FILE-HEADER STREAM 'RETURN)))
          (COND
             ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE]
              (LOADFROM FILE)                                (* ; 
                                                           "also calls addfile to notice the file.")
              ))
          (/replace FILECHANGES of FL with (FILECHANGES FC))
          [/replace FILEDATES of FL with
                                            (LIST (create FILEDATEPAIR
                                                         FILEDATE _ (CADR FC)
                                                         DATEFILENAME _ FILE)
                                                  (create FILEDATEPAIR
                                                         FILEDATE _
                                                         [CAR (SETQ TEM (CDR (MEMB 'date%: FC]
                                                         DATEFILENAME _ (CADR TEM]
          (RETURN FILE])

(MAKEFILE
  [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)           (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL;  LIST means list the FILE;  RC means RECOMPILE, C means COMPILEL;  --- for C AND RC assume ST unless next option is F.")

    (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS]
                           PRETTYFLG))
           (*PRINT-BASE* (if (EQ *PRINT-BASE* 8)
                             then 8
                           else                          (* ; "make sure radix is either 8 or 10, because all others don't read in like they print.  Maybe obsolete now with makefile environments")
                                 10))
           FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
          (DECLARE (CL:SPECIAL PRETTYFLG))
          (SETQ FILE (CAR Z))                                (* ; 
                                               "Necessary because FILE might have been misspelled.")
          (SETQ ROOTNAME (CADR Z))                           (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.")
          (SETQ FILEPROP (CDDR Z))
          (UPDATEFILES)                                  (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.")
          (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
          (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
          (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE))
      LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
                       (NULL FILEDATES))
              then                                       (* ; 
                   "File has never been loaded and never dumped i.e. user just set up COMS in core")
            elseif [OR (EQMEMB 'NEW OPTIONS)
                           (AND (NULL MAKEFILEREMAKEFLG)
                                (NOT (MEMB 'REMAKE OPTIONS]
              then (COND
                          ((AND (fetch LOADTYPE of FILEPROP)
                                (NEQ T (fetch LOADTYPE of FILEPROP)))
                           (LISPXPRIN2 FILE T T)
                           (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
                                           (LOADCOMP 
                                                  "the file was loaded for compilation purposes only")
                                           ((compiled Compiled COMPILED) 
                                                " -- only the compiled file has been loaded
")
                                           ((loadfns LOADFNS) 
                                                " -- only some of its symbolics have been loaded
")
                                           (SHOULDNT))
                                  T)
                           (COND
                              ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ")
                                    'Y)                      (* ; 
            "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.")
                               (GO OUT)))
                           (/replace LOADTYPE of FILEPROP with NIL)))
                    (SETQ SOURCEFILE NIL)
                    (SETQ REPRINTFNS NIL)
            elseif SOURCEFILE
              then                                       (* ; "source file given")
            elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T))
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
                                          (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE
                                                                              (fetch DATEFILENAME
                                                                                 of (CAR 
                                                                                            FILEDATES
                                                                                             ]
                                               (INFILEP SOURCEFILE)
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
              then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
                    (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
            elseif [AND (CDR FILEDATES)
                            [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
                            (EQUAL (FILEDATE SOURCEFILE)
                                   (fetch FILEDATE of (CADR FILEDATES]
              then 

                    (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.")

                    (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
                                         (fetch FILECHANGES of ROOTNAME)))
                    (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
            else (LISPXPRIN1 
                            '"can't find either the previous version or the original version of 
" T)
                  (LISPXPRIN2 FILE T T)
                  (LISPXPRIN1 '", so it will have to be written anew
" T)
                  (SETQ SOURCEFILE NIL)
                  (SETQ REPRINTFNS NIL)
                  (push OPTIONS 'NEW)
                  (SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
                  (GO LP0))
          (COND
             ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
                                          (LOADCOMP          (* ; 
                                                   "only loaded via LOADCOMP.  Need to do LOADFROM")
                                                    (LIST 'N SOURCEFILE "was loaded with LOADCOMP"
                                                          '- "LOADFROM it to obtain VARS/COMS"))
                                          (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%:
                                                                (fetch COMSNAME of FILEPROP))
                                                         (LIST 'Y "only compiled version of" ROOTNAME
                                                               
                                        "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions"
                                                               )))
                                          ((compiled loadfns) 
                                               (LIST 'N "Only some functions from" SOURCEFILE 
                                             "loaded via LOADFNS. Load all other expressions from it"
                                                     ))
                                          NIL)))
              (SELECTQ [ASKUSER DWIMWAIT (CAR Z)
                              (CDR Z)
                              '((Y "es
")
                                (N "o
")
                                (A "bort MAKEFILE
"]
                  (Y (SELECTQ (fetch LOADTYPE of FILEPROP)
                         (LOADCOMP                           (* ; 
                               "file was never actually loaded, just loadcomped.  thus no filecoms")
                                   (LOADFROM SOURCEFILE))
                         (Compiled 

                                 (* ;; "This is going to be a remake.  If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.")

                                   (LOADVARS 'DONTCOPY SOURCEFILE)
                                   (/replace LOADTYPE of FILEPROP with 'COMPILED)
                                                             (* ; "So wont have to be done again.")

                                 (* ;; "These are the only DECLARE:'s that are not also on the compiled file.  Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE:  Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)")

                                   )
                         ((loadfns compiled) 

                                 (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.")

                              (LOADVARS T SOURCEFILE))
                         NIL))
                  (A (GO OUT))
                  NIL)))
          (RESETLST
              [COND
                 ((MEMB 'NOCLISP OPTIONS)
                  (RESETSAVE PRETTYTRANFLG T))
                 ((MEMB 'CLISP%  OPTIONS)
                  (RESETSAVE PRETTYTRANFLG 'BOTH]
              (RESETSAVE %#UNDOSAVES)
              [COND
                 ((OR (MEMB 'CLISPIFY OPTIONS)
                      (MEMB 'CLISP OPTIONS))
                  (RESETSAVE CLISPIFYPRETTYFLG T))
                 ((OR (EQ FILETYPE 'CLISP)
                      (MEMB 'CLISP (LISTP FILETYPE)))
                  (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES]
              (for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
              (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
                                REPRINTFNS SOURCEFILE CHANGES)))
          (SETQ LASTFILE ROOTNAME)
          (/replace TOBEDUMPED of FILEPROP with NIL)
          (COND
             ((NOT (EQMEMB 'DON'TLIST FILETYPE))
              (pushnew NOTLISTEDFILES ROOTNAME)))
          (COND
             ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE))
              (pushnew NOTCOMPILEDFILES ROOTNAME)))
          [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL))
                                                 (SELECTQ OPT
                                                     (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                              (MAKEFILE1 FILE T (CDR TAIL))))
                                                     (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                             (MAKEFILE1 FILE NIL (CDR TAIL))))
                                                     (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
                                                                (APPLY 'LISTFILES (LIST FILE))))
                                                     (COND
                                                        ((MEMB OPT MAKEFILEOPTIONS))
                                                        ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL 
                                                                OPTIONS)
                                                         (GO $$LP))
                                                        (T (ERROR "Unrecognized MAKEFILE option" OPT]
          (RETURN FILE)
      OUT (RETURN (LIST FILE "-- MAKEFILE not performed."])

(FILECHANGES
  [LAMBDA (FILE TYPE)                                    (* bvm%: "30-Aug-86 15:08")

    (* ;; "If FILE is a list, it is assumed to be a file-created expressions;  otherwise, the filecreated expression is read from FILE.  If TYPE, returns the list of changed items of that type from the changes expression.  If TYPE=NIL, returns the whole list of typed change-lists")

    (PROG ([FCEXPR (OR (LISTP FILE)
                       (AND FILE (RESETLST
                                     (LET (OLDPTR STREAM)
                                          [if (SETQ STREAM (OPENP FILE 'INPUT))
                                              then (SETQ OLDPTR (GETFILEPTR STREAM))
                                                    (SETFILEPTR STREAM 0)
                                            else (RESETSAVE NIL (LIST 'CLOSEF
                                                                          (SETQ STREAM
                                                                           (OPENSTREAM FILE
                                                                                  'INPUT]
                                          (CL:MULTIPLE-VALUE-BIND (ENV FC)
                                                 (\PARSE-FILE-HEADER STREAM 'RETURN)
                                                 (if OLDPTR
                                                     then (SETFILEPTR STREAM OLDPTR))
                                                 FC)))]
           FNS CHANGES)
          (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR)))
                               (MEMB 'previous CHANGES)))
          [if (AND TYPE (NEQ TYPE 'FNS))
              then (RETURN (CDR (ASSOC TYPE CHANGES]
          (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM)))     (* ; 
                         "Old style changes expression listed FNS by name and other things by type")
          (RETURN (if TYPE
                      then                               (* ; "TYPE=FNS cause of test above.")
                            (NCONC FNS (CDR (ASSOC 'FNS CHANGES)))
                    elseif FNS
                      then (CONS (CONS 'FNS FNS)
                                     (SUBSET CHANGES (FUNCTION LISTP)))
                    else CHANGES])

(FILEPKG.MERGECHANGES
  [LAMBDA (C1 C2)                                        (* rmk%: "24-MAY-82 23:09")

    (* ;; "Merges 2 changes lists into a single one.  Treat LITATOM's as FNS, to accomodate old-style format on files.")

    (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND
                                                                                         E1)))
       in C2 do [COND
                           ((SETQ TEMP (ASSOC (CAR E2)
                                              VAL))
                            (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP))
                                           collect X)))
                           (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL])

(FILEPKG.CHANGEDFNS
  [LAMBDA (CHANGES)                                      (* rmk%: "20-MAY-82 22:00")

    (* ;; "Returns list of function names from a file-changes list.  Interprets old format (functions are atoms) and new format (with explicit type headers)")

    (CDR (ASSOC 'FNS CHANGES])

(MAKEFILE1
  [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES)            (* ; "Edited 29-Aug-89 11:46 by bvm")
    (PROG* ((ROOTNAME (ROOTFILENAME FILE))
            (COMPILER (COMPILE-FILE? ROOTNAME))
            GROUP)
           (COND
              ((AND (OR (EQ COMPILER 'BCOMPL)
                        (EQ COMPILER 'TCOMPL))
                    (NOT (FILEFNSLST ROOTNAME)))         (* ; 
                 "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.")
               (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
               (RETURN NIL)))
           (COND
              ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP))
                  suchthat (AND (NEQ X ROOTNAME)
                                    (OR (fetch TOBEDUMPED of (fetch FILEPROP of
                                                                                         X))
                                        (MEMB X OTHERFILES]

               (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled.  Wait.")

               (RETURN)))
           (LISPXPRIN1 '"
compiling " T)
           (LISPXPRINT (OR GROUP FILE)
                  T T)
           (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS)
                                                'ST)
                                            (EQ (CAR OPTIONS)
                                                'STF]
                             (FORGET-EXPRS? (EQ (CAR OPTIONS)
                                                'STF]
                            (SELECTQ COMPILER
                                ((FAKE-COMPILE-FILE)         (* ; 
                                               "The old CommonLispy interface to the ByteCompiler.")
                                     (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS
                                            (AND REDEFINE? (NOT FORGET-EXPRS?))))
                                ((CL:COMPILE-FILE)           (* ; "The new, improved (?) compiler")
                                     (CL:COMPILE-FILE FILE :LOAD (COND
                                                                    ((AND REDEFINE? (NOT 
                                                                                        FORGET-EXPRS?
                                                                                         ))
                                                                     :SAVE)
                                                                    (REDEFINE? T)
                                                                    (T NIL))))
                                ((TCOMPL BCOMPL)             (* ; "The old ByteCompiler")
                                     [IF (MEMB (CAR OPTIONS)
                                                   '(ST F S STF))
                                         THEN (LISPXUNREAD (LIST (CAR OPTIONS]
                                     [IF GROUP
                                         THEN 

                                               (* ;; 
                                   "File contained in FILEGROUP.  Therefore must be blockcompiled.")

                                               (IF RECOMPFLG
                                                   THEN (BRECOMPILE GROUP)
                                                 ELSE (BCOMPL GROUP))
                                       ELSEIF (EQ COMPILER 'TCOMPL)
                                         THEN (IF RECOMPFLG
                                                      THEN (RECOMPILE FILE)
                                                    ELSE (TCOMPL (LIST FILE)))
                                       ELSE (IF RECOMPFLG
                                                    THEN (BRECOMPILE FILE)
                                                  ELSE (BCOMPL (LIST FILE])
                                (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?...")))
                  T T])

(COMPILE-FILE?
  [LAMBDA (ROOTNAME)                                     (* ; "Edited 19-Jan-87 21:12 by Pavel")

(* ;;; "Which compiler should CLEANUP use?")

    (LET ((TYPE (GET ROOTNAME 'FILETYPE))
          (UNKNOWN NIL))
         (FOR X INSIDE TYPE DO (SELECTQ X
                                               ((TCOMPL :TCOMPL) 
                                                    (RETURN 'TCOMPL))
                                               ((BCOMPL :BCOMPL) 
                                                    (RETURN 'BCOMPL))
                                               ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) 
                                                    (RETURN 'FAKE-COMPILE-FILE))
                                               ((:COMPILE-FILE :XCL-COMPILE-FILE) 
                                                    (RETURN 'CL:COMPILE-FILE))
                                               ((CLISP) 
                                                    NIL)
                                               (SETQ UNKNOWN T))
            FINALLY (IF UNKNOWN
                            THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE
                                            ))
                  (RETURN *DEFAULT-CLEANUP-COMPILER*])

(MAKEFILES
  [LAMBDA (OPTIONS FILES)                                (* rmk%: "23-FEB-83 21:20")
    (RESETVARS (%#UNDOSAVES)                                 (* ; 
                                                   "Willing to save arbitrary amounts of undo info")
               (UPDATEFILES)
               [COND
                  ((NULL FILES)
                   (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE
                                                                         (COND
                                                                            ((NULL FLG)
                                                             (* ; "Gets printed the first time")
                                                                             
                                                                             '
                                        "****NOTE: the following are not contained on any file:
    ")
                                                                            (T '"    "]
                      do (SETQ FLG T) finally (AND FLG (ADDTOFILES?]
               (SETQ OPTIONS (MKLIST OPTIONS))
               (RETURN (for FILE inside (OR FILES FILELST)
                          when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP
                                                                          of (ROOTFILENAME FILE]
                          collect (LISPXPRIN2 FILE T T)
                                (LISPXPRIN1 '|...| T)
                                (PROG1 (MAKEFILE FILE OPTIONS)
                                       (LISPXTERPRI T])

(ADDFILE
  [LAMBDA (FILE LOADTYPE PRLST FCLST)                    (* bvm%: "29-Aug-86 12:22")

    (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           FLST VAL)
          [COND
             ((NOT FCLST)
              (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE)))
             [(NULL (CDR FCLST))                             (* ; "A simple symbolic file")
              (SETQ FCLST (CAR FCLST))
              (SETQ VAL (ADDFILE0 (COND
                                         ((LITATOM (CADR FCLST))
                                          (ROOTFILENAME (CADR FCLST)))
                                         (T ROOTNAME))
                               LOADTYPE FILE (CAR FCLST]
             (T 
                (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.")

                (SELECTQ LOADTYPE
                    ((T LOADFNS) 
                         (SETQ LOADTYPE 'Compiled))
                    (loadfns (SETQ LOADTYPE 'compiled))
                    (LOADCOMP                                (* ; 
                   "loadcomp on compiled file.  Don't notice since we don't know what its state is")
                              NIL)
                    (SHOULDNT))
                (for X in (CDR FCLST) when (LITATOM (CADR X))
                   do (push FLST (CADR X))
                         (OR (EQ LOADTYPE 'LOADCOMP)
                             (ADDFILE0 (ROOTFILENAME (CADR X))
                                    LOADTYPE
                                    (CADR X)
                                    (CAR X]
          (UPDATEFILES PRLST (OR FLST (LIST FILE)))
          [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES
                           when (AND (LITATOM TYPE)
                                         (SETQ CHANGED (fetch CHANGED of TYPE)))
                           do (/replace CHANGED of TYPE
                                     with (INTERSECTION (CDR (ASSOC TYPE PRLST))
                                                     CHANGED]
          (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS))
          (RETURN VAL])

(ADDFILE0
  [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT)               (* lmm "28-Nov-84 16:47")
    (PROG (COMS X FILEPROP FLG TEM)
      TOP (SETQ COMS (FILECOMS ROOTNAME))
          [COND
             ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME))
              (COND
                 ([AND LOADTYPE (FMEMB LOADTYPE
                                       (CDR (FMEMB (fetch LOADTYPE of FILEPROP)
                                                   '(LOADCOMP loadfns compiled Compiled LOADFNS 
                                                           COMPILED NIL T]
                  (/replace LOADTYPE of FILEPROP with LOADTYPE)

                  (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property.  'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file.  'Compiled' means all but DECLARE: expressions are in.  e.g. user does LOAD of a compiled file.  COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.  LOADFNS means everything in, e.g. user des LOADFROM symbolic file.  COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted.  NIL is a makefile when coms were set up in core.  T is full load of symbolic file.  The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.")

                  (* ;; "LOADCOMP means file was loadcomp'ed.  note that the actual structure is a tree, not a list, and the above is only an approximation.  if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc.  however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.")

                  (GO OUT))
                 (T (GO OUT1]
          (COND
             [(OR LOADTYPE (LISTP (GETTOPVAL COMS)))
              (SETQ FILEPROP (/replace FILEPROP of ROOTNAME
                                with (create FILEPROP
                                                COMSNAME _ COMS
                                                LOADTYPE _ LOADTYPE]
             (FLG (GO ERROR))
             ((AND DWIMFLG (EQ ROOTNAME FULLNAME)
                   (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T)))

              (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.")

              (SETQ FULLNAME ROOTNAME)
              (SETQ FLG T)                                   (* ; 
                                         "so wont try to spelling correct again if file isnt there")
              (GO TOP))
             (T (GO ERROR)))
      OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME
                               with (LIST (create FILEDATEPAIR
                                                     FILEDATE _ DAT
                                                     DATEFILENAME _ FULLNAME]
          (AND (EQ LOADTYPE T)
               (/replace TOBEDUMPED of FILEPROP with NIL))
      OUT1
          [COND
             ([AND (LISTP (GETTOPVAL COMS))
                   (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ; 
                                                          "coms wuld not be set up on a loadccomp.")
              (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST]
          (RETURN (COND
                     ((NULL LOADTYPE)                        (* ; "call from makefile.")
                      (CONS FULLNAME (CONS ROOTNAME FILEPROP)))
                     (T FILEPROP)))
      ERROR
          (ERROR FULLNAME "not file name." T])

(LISTFILES
  [NLAMBDA FILES                                         (* rmk%: " 3-Dec-84 08:58")
    (DECLARE (GLOBALVARS NOTLISTEDFILES))                (* ; "LISTFILES1 is machinedependent")
    (for FILE FULLNAME OPTIONS in (COND
                                             (FILES (SETQ FILES (NLAMBDA.ARGS FILES)))
                                             (T NOTLISTEDFILES))
       when (COND
                   ((LISTP FILE)
                    (SETQ OPTIONS (APPEND FILE OPTIONS))
                    NIL)
                   ((SETQ FULLNAME (FINDFILE FILE))
                    FULLNAME)
                   (T (printout T FILE " not found." T)
                      NIL)) collect [COND
                                           ((LISTFILES1 FULLNAME OPTIONS)
                                            (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
                                                                        NOTLISTEDFILES]
                                  FULLNAME])
)

(RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)

(RPAQ? FILELST )

(RPAQ? LOADEDFILELST )

(RPAQ? NOTLISTEDFILES )

(RPAQ? NOTCOMPILEDFILES )

(RPAQ? MAKEFILEFORMS )

(RPAQ? NILCOMS )

(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP%  F ST STF
                                 (REC . RC)
                                 (BREC . RC)
                                 (TC . C)
                                 (BC . C)
                                 (TCOMPL . C)
                                 (BCOMPL . C))

(RPAQ? MAKEFILEREMAKEFLG T)

(RPAQ? CLEANUPOPTIONS '(RC))



(* ;; "scanning file coms")

(DEFINEQ

(FILEPKGCHANGES
  [LAMBDA N                                              (* Pavel " 7-Oct-86 19:22")
    (COND
       [(EQ N 0)
        (PROG (TEM)
              (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X)
                                                                   (SETQ TEM (FILEPKGCHANGES
                                                                              X)))
                         collect (CONS X TEM]
       [(EQ (ARG N 1)
            T)
        (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES
                                                                                 X]
       [(EQ N 1)
        (COND
           [(LISTP (ARG N 1))
            (for X in (ARG N 1) when (FMEMB (CAR X)
                                                        FILEPKGTYPES)
               do (/replace CHANGED of (CAR X) with (CDR X]
           (T (for Y on (fetch CHANGED of (ARG N 1))
                 when [AND (CAR Y)
                               (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y)
                                                                                 Z]
                 collect (CAR Y]
       (T (/replace CHANGED of (ARG N 1) with (ARG N 2])

(GETFILEPKGTYPE
  [LAMBDA (TYPE ONLY NOERROR NAME)                       (* lmm "20-Nov-86 23:10")

    (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ")

    (COND
       [(LISTP TYPE)

        (* ;; " given a list of types, coerce them all or return NIL")

        (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME)
                                               (RETURN]
       ((EQ TYPE '?)

        (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ")

        (AND NAME (TYPESOF NAME)))
       [(AND (NEQ ONLY 'COMS)
             (OR (SELECTQ TYPE
                     (NIL 'FNS)
                     (T 'VARS)
                     NIL)
                 (for X in FILEPKGTYPES do (if (EQ TYPE X)
                                                           then 

                                                                 (* ;; "type matched exactly")

                                                                 (RETURN TYPE)
                                                         elseif (AND (LISTP X)
                                                                         (EQ TYPE (CAR X)))
                                                           then (RETURN (CDR X]
       [(AND (NEQ ONLY 'TYPE)
             (LITATOM TYPE)
             (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST))       (* ; "Prefer an exact match quickly")
                    ]
       [(AND (NEQ ONLY 'COMS)
             (LITATOM TYPE)
             (for X in FILEPKGTYPES bind NAME
                do (SETQ NAME (if (NLISTP X)
                                      then X
                                    else (CAR X))) 

                      (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization")

                      (AND (<= 0 (- (NCHARS NAME)
                                    (NCHARS TYPE))
                               1)
                           (STRPOS TYPE NAME)
                           (RETURN (if (EQ X NAME)
                                       then X
                                     else (CDR X]
       [(FIXSPELL TYPE NIL (SELECTQ ONLY
                               (TYPE FILEPKGTYPES)
                               (COMS FILEPKGCOMSPLST)
                               (UNION FILEPKGTYPES FILEPKGCOMSPLST]
       ((NOT NOERROR)
        (ERROR (SELECTQ ONLY
                   (TYPE "unrecognized manager definition type")
                   (COMS "unrecognized manager command")
                   "unrecognized manager definition-type/command")
               TYPE])

(MARKASCHANGED
  [LAMBDA (NAME TYPE REASON)                             (* ; "Edited 25-May-88 15:37 by drc:")
    (COND
       (FILEPKGFLG (SETQ REASON (SELECTQ REASON
                                    ((CLISP LOAD CHANGED DEFINED DELETED) 
                                         REASON)
                                    (NIL 'CHANGED)
                                    (T 'DEFINED)
                                    (ERROR "bad REASON in MARKASCHANGED" REASON)))
              (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (for FN inside (fetch WHENCHANGED of TYPE)
                 do (APPLY* FN NAME TYPE REASON))
              (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON))
              [COND
                 ((EQ REASON 'DELETED)
                  (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L)
                                                                                    NAME)
                     do (/RPLACA L NIL))                 (* ; 
                                                          "unmark as changed and remove from files")
                  (DELFROMFILES NAME TYPE))
                 (T (LET ((LST (push (fetch CHANGED of TYPE)
                                      NAME)))
                         (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST)
                                               LISPXHIST))   (* ; 
                             "UNDO by smashing with NIL;  makes calls to MARKASCHANGED independent")
                         ]
              NAME])

(FILECOMS
  [LAMBDA (FILE X)                                       (* rmk%: "19-FEB-83 13:55")
    (COND
       ((AND (NULL FILE)
             (NULL X))
        'NILCOMS)
       [(AND (OR (NULL X)
                 (EQ X 'COMS))
             (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE]
       (T (PACK* (NAMEFIELD FILE)
                 (OR X 'COMS])

(WHEREIS
  [LAMBDA (NAME TYPE FILES FN)                        (* ; "Edited 12-Jul-88 17:14 by MASINTER")

    (* ;; "T as a NAME has a special meaning to INFILECOMS?  so don't pass through.")

    (CL:UNLESS (EQ NAME T)
        (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES)
                                           FILELST)
                                      (FUNCTION (LAMBDA (FILE)
                                                  (INFILECOMS? NAME TYPE (FILECOMS FILE]
                               (AND (EQ FILES T)
                                    (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS)
                                    (LET ((FILES NIL))
                                         (for TY inside TYPE
                                            do (for FILE-NAME
                                                      in (XCL::HASH-FILE-WHERE-IS NAME
                                                                    (GETFILEPKGTYPE TYPE))
                                                      do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME))
                                                                    FILES)))
                                         (REVERSE FILES]
             (CL:IF FN
                 [MAPC IN-FILES (FUNCTION (LAMBDA (FILE)
                                            (APPLY* FN NAME FILE]
                 IN-FILES)))])

(SMASHFILECOMS
  [LAMBDA (FILE)                                         (* rmk%: "19-FEB-83 22:15")
    (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X)
       do (SETTOPVAL X 'NOBIND))
    FILE])

(FILEFNSLST
  [LAMBDA (FILE)                                         (* ; "Edited 14-Jun-90 19:30 by jds")
    (FILECOMSLST FILE '(FUNCTIONS FNS])

(FILECOMSLST
  [LAMBDA (FILE TYPE FLG)                                (* JonL "24-Jul-84 19:48")
                                                             (* ; 
                                                    "TYPE is coerced in the innards of INFILECOMS?")
    (COND
       ((EQ FLG 'UPDATE)
        (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE)
                    FLG)))
       (T (INFILECOMS? NIL TYPE (FILECOMS FILE)
                 FLG])

(UPDATEFILES
  [LAMBDA (PRLST FLST)                                   (* rmk%: "19-FEB-83 14:27")

    (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g.  LOAD, LOADFNS) involving the files in FLST began.")

    (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE))
       do (COND
                 ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE)))
                                                             (* ; 
                                                           "FILEPKGCHANGES eliminates duplicates")
                  (/replace CHANGED of TYPE with NIL))
                 (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES
                           (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST
                       first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) 

                             (* ;; "First check NIL=Nowhere.  LST:1 contains variables whose values are on the file literally.  These are `found' but not marked.  LST::1 contains all other items.")

                             (SETQ FOUND (NCONC (CAR LST)
                                                (CDR LST)
                                                FOUND))
                       do (SETQ PCHANGES (COND
                                                ((FMEMB (fetch DATEFILENAME
                                                           of (CAR (fetch FILEDATES
                                                                          of FILE)))
                                                        FLST)

                                 (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began.  Thus, by this intersection we only worry about items that were previously changed;  any items that were only changed during this operation are ignored.")

                                                 (INTERSECTION CHANGED PREVITEMS))
                                                (T CHANGED)))
                             [COND
                                ([AND PCHANGES [SETQ COMS (fetch COMSNAME
                                                             of (SETQ FILEPROP
                                                                     (LISTP (fetch FILEPROP
                                                                               of FILE]
                                      (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE]

                                 (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms")

                                 [COND
                                    ((CDR LST)               (* ; "CDR items must be distributed")
                                     [COND
                                        ((NULL (fetch TOBEDUMPED of FILEPROP))

                                         (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL")

                                         [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL
                                                                                   'NOTLISTEDFILES]
                                         (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE
                                                                              (GETTOPVAL 
                                                                                     '
                                                                                     NOTCOMPILEDFILES
                                                                                     ]
                                                             (* ; 
                                                   "Get the (possibly new) TYPE item list to smash")
                                     [COND
                                        [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED
                                                                        of FILEPROP]
                                        (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE]
                                                             (* ; 
                                                        "Now distribute items to the file property")
                                     (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP)
                                                                                   )
                                        do (/NCONC1 TYPEDPROP Y]
                                 (SETQ FOUND (NCONC (CAR LST)
                                                    (CDR LST)
                                                    FOUND] finally (/replace CHANGED
                                                                          of TYPE
                                                                          with (LDIFFERENCE
                                                                                    CHANGED FOUND])

(INFILECOMS?
  [LAMBDA (NAME TYPE COMS ONFILETYPE)                 (* ; "Edited 12-Jul-88 17:42 by MASINTER")

    (* ;; "Returns T if NAME is 'CONTAINED' in COMS.  If NAME is NIL, then value is a list of all of the functions contained in COMS.  If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.)  Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1.  while elements are the subset of NAME which are on the file in other case")

    (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS?  returns the dotted pair of (literals  . elements) where literals are those which are `literally' on the file (e.g.  (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")

    (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ")

    (PROG (VAL LITERALS ORIGFLG)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (SELECTQ ONFILETYPE
              (EDIT (SELECTQ TYPE
                        (FILEVARS (RETURN))
                        NIL))
              NIL)
          [COND
             ((LITATOM COMS)
              (SELECTQ TYPE
                  ((VARS FILEVARS)                           (* ; 
                                                           "the COMS of a file are also on it")
                       (INFILECOMSVAL COMS))
                  NIL)
              (SETQ COMS (EVALV COMS]
          (INFILECOMS COMS)
          (SETQ VAL (DREVERSE VAL))
          (RETURN (COND
                     ((EQ ONFILETYPE 'UPDATE)
                      (CONS LITERALS VAL))
                     (T VAL])

(INFILECOMTAIL
  [LAMBDA (COM FLG)                                   (* ; "Edited  2-Aug-88 02:15 by masinter")
    [SETQ COM (COND
                 ((EQ (CADR COM)
                      '*)
                  (COND
                     [(LITATOM (CADDR COM))
                      (LISTP (EVALV (CADDR COM]
                     (T [RESETVARS (DWIMLOADFNSFLG)
                                   (NLSETQ (SETQ COM (EVAL (CADDR COM]
                        COM)))
                 (T (CDR COM]
    (if (NOT FLG)
        then (for X in COM
                    do [if (AND (LISTP X)
                                        (EQ (CAR X)
                                            COMMENTFLG))
                               then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X)
                                                                        (OR (NLISTP X)
                                                                            (NEQ (CAR X)
                                                                                 COMMENTFLG]
                    finally (RETURN COM))
      else COM])

(INFILECOMS
  [LAMBDA (COMS)                                         (* rmk%: "19-FEB-83 22:17")
    (for X in COMS do (INFILECOM X])

(INFILECOM
  [LAMBDA (COM)                                       (* ; "Edited  2-Aug-88 02:27 by masinter")
    (COND
       [(NLISTP COM)
        (COND
           ((EQ TYPE 'VARS)
            (INFILECOMSVAL COM]
       ((EQ (CAR COM)
            COMMENTFLG)

        (* ;; 
"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
                                                             (* ; 
  "don't know why I should bother, but someone might want to know all of the comments on a file???")
        (COND
           ((EQ TYPE COMMENTFLG)
            (INFILECOMSVAL COM T)))
        NIL)
       (T
        (PROG ((COMNAME (CAR COM))
               (TAIL (CDR COM))
               CFN TEM)
              (COND
                 [[COND
                     ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
                      (SETQ TEM (APPLY* CFN COM (COND
                                                   ((AND (NULL ONFILETYPE)
                                                         (NOT (CL:SYMBOLP NAME)))
                                                             (* ; 
                                                "call from WHEREIS of a name which is not a symbol")
                                                    (LIST NAME))
                                                   (T NAME))
                                       TYPE ONFILETYPE)))
                     ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
                                                             (* ; "for compatability")
                      (SETQ TEM (APPLY* CFN COM TYPE NAME]
                  (COND
                     [(NLISTP TEM)
                      (COND
                         ((EQ TEM T)
                          (COND
                             ((OR (EQ NAME T)
                                  (NULL ONFILETYPE))
                              (RETFROM 'INFILECOMS? T]
                     (T (INFILECOMSVALS TEM]
                 ((LISTP TAIL)

                  (* ;; "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")

                  (SELECTQ COMNAME
                      ((PROP IFPROP) 
                           (SETQ TAIL (CDR TAIL)))
                      NIL)
                  [COND
                     ((EQ (CAR TAIL)
                          '*)
                      (COND
                         ((LITATOM (CADR TAIL))
                          (SELECTQ TYPE
                              ((VARS FILEVARS) 
                                   (INFILECOMSVAL (CADR TAIL)))
                              NIL))
                         ((AND (LISTP (CADR TAIL))
                               (EQ ONFILETYPE 'UPDATE)
                               (EQ TYPE 'VARS)
                               (EQ (CAADR TAIL)
                                   'PROGN)
                               (FMEMB (CAR (LAST (CADR TAIL)))
                                      NAME))
                          (SETQ VAL (CONS (CADR TAIL)
                                          VAL]
                  (SELECTQ COMNAME
                      ((COMS EXPORT) 
                           (INFILECOMS (INFILECOMTAIL COM T)))
                      (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM)
                                                           T)))
                      (DECLARE%:                             (* ; "skip over DECLARE: tags")
                                 [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM))
                                              (IFCDECLARE (INFILECOMTAIL COM)
                                                     (EQ TYPE 'DECLARE%:])
                      (ORIGINAL                              (* ; "dont expand macros")
                                (PROG ((ORIGFLG T))
                                      (INFILECOMS (INFILECOMTAIL COM T))))
                      ((PROP IFPROP)                         (* ; 
                                       "this currently does not handle `pseudo-types' of PROPNAMES")
                           (SELECTQ TYPE
                               (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM)
                                                              T)
                                             (CADR COM)))
                               (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
                                              (CADR COM)))
                               NIL))
                      (PROPS (RETURN (IFCPROPS COM)))
                      (MACROS (RETURN (SELECTQ TYPE
                                          (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T)
                                                        MACROPROPS))
                                          (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T)))
                                          NIL)))
                      (ALISTS                                (* ; 
                      "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")
                              (RETURN (SELECTQ TYPE
                                          (ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
                                          NIL)))
                      (P [RETURN (SELECTQ TYPE
                                     ((EXPRESSIONS P) 
                                          (INFILECOMSVALS (INFILECOMTAIL COM T)
                                                 T))
                                     (COND
                                        ((NULL ONFILETYPE)   (* ; "for WHEREIS and FILECOMSLST")
                                         (SELECTQ TYPE
                                             (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR))
                                             (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE))
                                             NIL])
                      ((ADDVARS APPENDVARS) 
                           (SELECTQ TYPE
                               (VARS [RETURN (AND (NULL ONFILETYPE)
                                                  (for X in (INFILECOMTAIL COM T)
                                                     do (INFILECOMSVAL (CAR X)
                                                                   T])
                               (ALISTS [RETURN (for X in (INFILECOMTAIL COM T)
                                                  when (EQMEMB 'ALIST (GETPROP (CAR X)
                                                                                 'VARTYPE))
                                                  do (for Z in (CDR X)
                                                            do (INFILECOMSVAL
                                                                    (LIST (CAR X)
                                                                          (CAR Z))
                                                                    T])
                               (OR (EQ TYPE COMNAME)
                                   (RETURN))))
                      ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) 
                           [RETURN (COND
                                      ((EQ TYPE 'EXPRESSIONS)
                                       (for X in (INFILECOMTAIL COM T)
                                          when (AND (LISTP X)
                                                        (NEQ (CAR X)
                                                             COMMENTFLG))
                                          do (INFILECOMSVAL (CONS 'SETQ X)
                                                        T)))
                                      ((OR (EQ TYPE 'VARS)
                                           (EQ TYPE COMNAME))(* ; 
                   "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
                                       (for X in (INFILECOMTAIL COM T)
                                          do (COND
                                                    ((LISTP X)
                                                     (AND (CAR X)
                                                          (NEQ (CAR X)
                                                               COMMENTFLG)
                                                          (INFILECOMSVAL (CAR X)
                                                                 T)))
                                                    (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS])
                      (DEFS [RETURN (for X in (INFILECOMTAIL COM T)
                                       when (EQ TYPE (CAR X)) do (INFILECOMSVALS
                                                                          (CDR X])
                      (FILES (RETURN))
                      NIL)

                  (* ;; "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")

                  (COND
                     ((EQ COMNAME TYPE)
                      (INFILECOMSVALS (INFILECOMTAIL COM T)))
                     [(AND (LISTP TYPE)
                           (FMEMB COMNAME TYPE))
                      (LET ((TYPE COMNAME))
                           (INFILECOMSVALS (INFILECOMTAIL COM T]
                     ((AND (OR (NULL CFN)
                               (AND (EQ CFN T)
                                    (NULL ONFILETYPE)))
                           (NULL ORIGFLG)
                           (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
                      (INFILECOMS (SUBPAIR (CAR TEM)
                                             (INFILECOMTAIL COM T)
                                             (CDR TEM])

(INFILECOMSVALS
  [LAMBDA (X FLG)                                     (* ; "Edited  2-Aug-88 02:21 by masinter")
    (for Y in X when (NOT (AND (LISTP Y)
                                           (EQ (CAR Y)
                                               COMMENTFLG))) do (INFILECOMSVAL Y FLG])

(INFILECOMSVAL
  [LAMBDA (X FLG)                                     (* ; "Edited 12-Jul-88 17:56 by MASINTER")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND (OR (NULL NAME)
                 (MEMBER X NAME))
             (COND
                (FLG (SETQ LITERALS (CONS X LITERALS)))
                (T (SETQ VAL (CONS X VAL]
       ((AND (EQ ONFILETYPE 'EDIT)
             FLG)                                            (* ; 
                                        "literals should not be edited as they are on the fileCOMS")
        NIL)
       ((EQ ONFILETYPE 'TYPESOF)
        (AND (COND
                ((LITATOM NAME)
                 (EQ NAME X))
                (T (EQUAL NAME X)))
             (CL:PUSHNEW TYPE VAL)))
       ([OR (EQ NAME T)
            (COND
               ((LITATOM NAME)
                (EQ NAME X))
               (T (EQUAL NAME X]
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS X VAL])

(INFILECOMSPROP
  [LAMBDA (AT PROP)                                      (* lmm "25-SEP-81 17:15")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND [OR (NULL NAME)
                 (find X in NAME suchthat (AND (EQ (CAR X)
                                                               AT)
                                                           (EQ (CADR X)
                                                               PROP]
             (SETQ VAL (CONS (LIST AT PROP)
                             VAL]
       ((OR (EQ NAME T)
            (AND (EQ (CAR NAME)
                     AT)
                 (EQ (CADR NAME)
                     PROP)))
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS (LIST AT PROP)
                        VAL])

(IFCPROPS
  [LAMBDA (COM)                                          (* bvm%: " 2-Dec-83 14:24")

(* ;;; "Examine a PROPS com for objects of specified TYPE")

    (SELECTQ TYPE
        (PROPS                                               (* ; 
                                       "the PROPS command can actually take (PROPNAME at1 at2 ...)")
               (INFILEPAIRS (INFILECOMTAIL COM)))
        (PROP                                                (* ; 
                                                "return the atoms which have any properties at all")
              (for PAIR in (INFILECOMTAIL COM) do (for ATNAME
                                                                     inside (CAR PAIR)
                                                                     do (INFILECOMSVAL ATNAME
                                                                                   ))))
        (MACROS                                              (* ; "only MACRO properties")
                (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR)
                                                                           (CDR PAIR))))
        NIL])

(IFCEXPRTYPE
  [LAMBDA (COM FN)                                       (* ; "Edited  6-Apr-87 20:20 by Pavel")

(* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN")

    (for SUBCOM in (INFILECOMTAIL COM)
       when (AND (EQ (CAR SUBCOM)
                         FN)
                     (EQ (CAR (LISTP (CADR SUBCOM)))
                         'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM))
                                                T])

(IFCPROPSCAN
  [LAMBDA (ATOMS PROPNAMES)                           (* ; "Edited  2-Aug-88 02:20 by masinter")

(* ;;; 
"Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES")

    (for AT in ATOMS WHEN (LITATOM AT) unless [COND
                                                                 [(EQ ONFILETYPE 'UPDATE)
                                                                  (COND
                                                                     (NAME (NOT (ASSOC AT NAME]
                                                                 ((LISTP NAME)
                                                                  (NEQ AT (CAR NAME]
       do (COND
                 ((EQ PROPNAMES 'ALL)
                  (for PROP in (GETPROPLIST AT) by (CDDR PROP)
                     when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP)))
                 (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])

(IFCDECLARE
  [LAMBDA (TAIL WANTDECLARE)                          (* ; "Edited  8-Jun-90 18:11 by teruuchi")
    (PROG ((TAIL TAIL))
      LP  (COND
             ((LISTP TAIL)
              [SELECTQ (CAR TAIL)
                  ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                       [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
                                                                 (CADR TAIL]
                       (SETQ TAIL (CDR TAIL)))
                  (DONTEVAL@LOAD [COND
                                    ((OR (\STKSCAN 'DOFILESLOAD)
                                         (\STKSCAN 'LOAD))
                                                  (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"")
                                     (RETURN))
                                    (WANTDECLARE (INFILECOMSVAL (CAR TAIL])
                  (COMPILERVARS (RETURN))
                  (COND
                     [(FMEMB (CAR TAIL)
                             DECLARETAGSLST)
                      (COND
                         (WANTDECLARE (INFILECOMSVAL (CAR TAIL]
                     (T (INFILECOM (CAR TAIL]
              (SETQ TAIL (CDR TAIL))
              (GO LP])

(INFILEPAIRS
  [LAMBDA (LST)                                          (* lmm " 4-DEC-78 09:51")
    (for LL in LST do (for X inside (CAR LL)
                                     do (for Y inside (CDR LL)
                                               do (INFILECOMSVAL (LIST X Y])

(INFILECOMSMACRO
  [LAMBDA (ATS PROPS)                                    (* lmm "28-SEP-78 18:35")

    (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.  --- Normally (e.g.  for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom.  However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties")

    (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE)
                                               (EVERY (PROPNAMES AT)
                                                      (FUNCTION (LAMBDA (X)
                                                                  (OR (NOT (FMEMB X MACROPROPS))
                                                                      (EQMEMB X PROPS]
                                           [SOME MACROPROPS (FUNCTION (LAMBDA (PROP)
                                                                        (EQMEMB PROP PROPS]
                                           (INFILECOMSVAL AT])
)



(* ;; "adding to a file")

(DEFINEQ

(FILES?
  [LAMBDA NIL                                            (* bvm%: "27-Oct-86 18:14")

(* ;;; 
"Display each file needing dumping, etc.  For files needing dumping, display details of why.")

    (UPDATEFILES)
    (LET (FILES CHANGES PRINTED)
         (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED
                                                                of (LISTP (fetch FILEPROP
                                                                                 of FILE]
            do (if (NOT PRINTED)
                       then (LISPXPRIN1 "To be dumped:
" T)
                             (SETQ PRINTED T))
                  (LISPXPRIN2 FILE T)
                  (LISPXPRIN1 " ...changes to " T)
                  [for CH in CHANGES bind TB
                     do (COND
                               ((LISTP CH)
                                [COND
                                   (TB (LISPXTAB TB NIL T))
                                   (T (SETQ TB (POSITION T]
                                (LISPXPRIN2 (CAR CH)
                                       T)
                                (FILES?PRINTLST (CDR CH)))
                               (T                            (* ; "old style")
                                  (LISPXPRIN2 CH T)
                                  (LISPXSPACES 1 T]
                  (LISPXTERPRI T))
         (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED "    plus "))
            do (SETQ FLG T) finally (if FLG
                                                then (OR PRINTED (LISPXPRIN1 "...to be dumped.  "
                                                                            T))
                                                      (ADDTOFILES?)))
         (if (SETQ FILES NOTCOMPILEDFILES)
             then (FILES?PRINTLST FILES "To be compiled: ")
                   (LISPXTERPRI T))
         (if (SETQ FILES NOTLISTEDFILES)
             then (FILES?PRINTLST FILES "To be listed: ")
                   (LISPXTERPRI T))
         (CL:VALUES])

(FILES?1
  [LAMBDA (TYPE FIRST)                                   (* bvm%: "27-Oct-86 18:17")

    (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.")

    (LET (STR LST)
         (COND
            ([AND (LITATOM TYPE)
                  (SETQ STR (fetch DESCRIPTION of TYPE))
                  (LISTP (SETQ LST (fetch CHANGED of TYPE]
             (AND FIRST (LISPXPRIN1 FIRST T))
             (LISPXPRIN1 '"the " T)
             (LISPXPRIN1 STR T)
             (FILES?PRINTLST LST)
             (LISPXTERPRI T)
             T])

(FILES?PRINTLST
  [LAMBDA (LST STR)                                      (* bvm%: "27-Oct-86 18:15")

    (* ;; "Print elements of LST separated by commas and indenting new lines a bunch.  If MAPRINT had a left margin arg, this would be simpler.")

    (MAPRINT LST T (OR STR ": ")
           NIL ", " [FUNCTION (LAMBDA (STR)
                                (COND
                                   ((> (+ (POSITION T)
                                          (NCHARS STR T T)
                                          3)
                                       (LINELENGTH NIL T))
                                    (LISPXTERPRI T)
                                    (LISPXPRIN1 "         " T)))
                                (LISPXPRIN2 STR T T]
           T])

(ADDTOFILES?
  [LAMBDA (NOASKSTR)                                     (* ; "Edited 21-Aug-91 10:13 by jds")

    (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says")

    (ERSETQ
     (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS]

      (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g.  changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES")

           [COND
              (NOASKSTR (PRIN1 NOASKSTR T))
              (T (DOBE)
                 (SETQ BUFS (READP T))
                 (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go")
                                 '((Y "es
")
                                   (N "o
")
                                   (%] "Nowhere
" EXPLAINSTRING "] - nowhere, all items will be marked as dummy
" NOECHOFLG T))
                                 T)
                     (N (RETURN))
                     (%] (for TYPE in FILEPKGTYPES
                            do (for NAME in (fetch (FILEPKGTYPE CHANGED)
                                                           of TYPE)
                                      do (ADDTOFILE NAME TYPE NIL)))
                         (RETURN))
                     NIL)                                    (* ; 
                              "if there was type-ahead BEFORE the askuser, then don't allow it now")
                 (COND
                    (BUFS (SETQ BUFS (COND
                                        ((READP T)
                                         (LINBUF)
                                         (SYSBUF)
                                         (SETQ BUFS (CLBUFS NIL T READBUF]
           [for TYPE STR LST in FILEPKGTYPES
              when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
                            (LISTP (SETQ LST (COND
                                                ((EQ TYPE 'VARS)
                                                 VARSCHANGES)
                                                (T (fetch (FILEPKGTYPE CHANGED) of TYPE]
              do
              (printout T "(" STR ")" T)
              (for NAME TEM FILE in LST when NAME
                 do
                 (PROG NIL
                   LP  (PRIN2 NAME T)
                       (SPACES 2 T)

                  (* ;; "if user typed ahead before entering addtofiles??  then dont allow typeahead here, because it will justgobble his earlier typeahead.")

                       (SELECTQ (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T))
                           (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)

                                 (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer")

                                              (DOBE)))
                               (GO LP))
                           (%] (SETQ FILE))
                           (%                                (* ; "space.  means no action")
                               (RETURN))
                           (%
 (PRINT (OR (SETQ FILE LASTFILE)
            'Nowhere)
        T))
                           (SETQ FILE TEM))
                       (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
                                         (SETQ PLACE (WHATIS FILE NIL TYPE))
                                         [COND
                                            ((LITATOM PLACE) (* ; "file name")
                                             (SETQ FILE PLACE)
                                             (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                                                        NAME TYPE NEAR LISTNAME)
                                                 (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                          (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.")

                                             )
                                            ((EQ (CAR PLACE)
                                                 'Near%:)
                                             (SETQ NEAR (CADR PLACE))
                                             (COND
                                                ([SOME FILELST (FUNCTION (LAMBDA (FL)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           FL))
                                                                            NAME TYPE NEAR LISTNAME]
                                                 (PRINT (LIST 'on FILE)
                                                        T T))
                                                (T (PRINT (LIST (CADR PLACE)
                                                                'not
                                                                'found)
                                                          T T)
                                                   (ERROR!)))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE)))
                                            ([OR [UNDONLSETQ (PROGN (SAVESET
                                                                     (SETQ LISTNAME (CAR PLACE))
                                                                     (MERGEINSERT
                                                                      NAME
                                                                      (LISTP (GETTOPVAL LISTNAME))
                                                                      T)
                                                                     T
                                                                     'NOPRINT)
                                                                    (OR (SETQ FILE
                                                                         (CAR (WHEREIS NAME TYPE
                                                                                     FILELST)))
                                                                        (ERROR!]
                                                 (SOME FILELST (FUNCTION (LAMBDA (X)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           X))
                                                                            NAME TYPE NEAR LISTNAME]
                                             (PRIN1 "  value is filed on " T)
                                             (PRINT FILE T T)
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                 (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed")

                                             )
                                            (T (PRIN1 "    put list " T)
                                               (PRIN2 (CAR PLACE)
                                                      T T)
                                               (SETQ FILE
                                                (WHATIS (ASKUSER NIL NIL " on file: "
                                                                   '(("" "" EXPLAINSTRING 
                                                                         "a file name" KEYLST ()))
                                                                   T)
                                                       'FILE))
                                               (SAVESET (CAR PLACE)
                                                      (MERGEINSERT NAME
                                                             (LISTP (GETTOPVAL (CAR PLACE)))
                                                             T)
                                                      T
                                                      'NOPRINT)

                                     (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.")

                                               (ADDNEWCOM (FILECOMS FILE)
                                                      NAME TYPE (CAR PLACE)
                                                      FILE)
                                               (for F in (fetch WHENFILED of TYPE)
                                                  do (for I in (GETTOPVAL (CAR PLACE))
                                                            do (APPLY* F I TYPE FILE]
                                         (AND FILE (ADDFILE FILE))
                                         (SETQ LASTFILE PLACE)))
                           (GO LP]
           (AND BUFS (BKBUFS BUFS))
           (UPDATEFILES])

(ADDTOFILE
  [LAMBDA (NAME TYPE FILE NEAR LISTNAME)                 (* lmm "21-Nov-84 11:43")
                                                             (* ; "adds NAME to the file FILE")
    (PROG (TEM COMSNAME)
          [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T)
                         (COND
                            ((FMEMB TYPE FILELST)
                             (GETFILEPKGTYPE (swap TYPE FILE)))
                            (T (GETFILEPKGTYPE TYPE]
          (SETQ FILE (WHATIS FILE 'FILE))
          (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                     NAME TYPE NEAR LISTNAME)
              (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
          (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))
          (AND FILE (NOT (FMEMB FILE FILELST))
               (ADDFILE FILE))
          (RETURN FILE])

(WHATIS
  [LAMBDA (USERINPUT ONLY)                               (* lmm "28-Nov-84 16:49")

    (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble;  if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable")

    (PROG (TEM UCASE)
          (RETURN (COND
                     ((NULL USERINPUT)                       (* ; "nowhere")
                      NIL)
                     [(LISTP USERINPUT)
                      (COND
                         (ONLY (ERROR!))
                         (T (SELECTQ (CAR USERINPUT)
                                ((@ Near%:) 
                                     (CONS 'Near%: (CDR USERINPUT)))
                                (WHATIS (CAR USERINPUT)
                                       'LIST]
                     ([AND (NEQ ONLY 'LIST)
                           (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT)))
                                      FILELST)
                               (LISTP (GETTOPVAL (FILECOMS UCASE)))
                               (SETQ TEM (FIXSPELL UCASE NIL FILELST T]
                      TEM)
                     ((AND (NEQ ONLY 'FILE)
                           (LISTP (GETTOPVAL USERINPUT)))
                      (LIST USERINPUT))
                     ((AND (NEQ ONLY 'LIST)
                           (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE)
                                      NIL T)
                               'Y))
                      UCASE)
                     ((AND (NEQ ONLY 'FILE)
                           (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT)
                                      NIL T)
                               'Y))
                      (LIST USERINPUT))
                     (T                                      (* ; "none of above")
                        (ERROR!])

(ADDTOCOMS
  [LAMBDA (COMS NAME TYPE NEAR LISTNAME)                 (* rmk%: "10-JUN-82 22:53")

    (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms);  return NIL if unsuccessful.  If LISTNAME is given, then only insert by adding to LISTNAME.  If NEAR is given, only insert near it")

    (COND
       ((NULL COMS)
        NIL)
       [(LITATOM COMS)                                       (* ; 
      "given a name of a command;  rebind COMSNAME to current variable and try to add to its value")
        (OR [PROG ((COMSNAME COMS))
                  (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME))
                                 NAME TYPE NEAR (AND (NEQ COMS LISTNAME)
                                                     LISTNAME]
            (AND (EQ COMS LISTNAME)
                 (ADDNEWCOM COMS NAME TYPE]
       (T (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (for TAIL on COMS do (COND
                                              [(LISTP (CAR TAIL))
                                               (COND
                                                  ((ADDTOCOM (CAR TAIL)
                                                          NAME TYPE NEAR LISTNAME)
                                                   (RETURN T]
                                              (T (SELECTQ (CAR TAIL)
                                                     ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                                                          (SETQ TAIL (CDR TAIL)))
                                                     NIL])

(ADDTOCOM
  [LAMBDA (COM NAME TYPE NEAR LISTNAME)                  (* ; "Edited  2-May-87 19:04 by Pavel")
                                                             (* ; 
                        "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful")
    (PROG (TEM)
          (COND
             ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM]
              (RETURN)))
          [COND
             ((SETQ TEM (fetch ADD of (CAR COM)))
              (RETURN (COND
                         ((OR (NULL LISTNAME)
                              (INFILECOMS? LISTNAME 'FILEVARS (LIST COM)))
                          (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR))
                               (MARKASCHANGED COMSNAME 'VARS))
                          TEM]
          (RETURN
           (SELECTQ (CAR COM)
               (FNS (AND (EQ TYPE 'FNS)
                         (ADDTOCOM1 COM NAME NEAR LISTNAME)))
               ((VARS INITVARS) 
                    (COND
                       ((OR (EQ (CAR COM)
                                'VARS)
                            NEAR LISTNAME)                   (* ; 
                                  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.")
                        (SELECTQ TYPE
                            (EXPRESSIONS (COND
                                            ((EQ (CAR NAME)
                                                 'SETQ)
                                             (ADDTOCOM1 COM (CDR NAME)
                                                    NEAR LISTNAME))))
                            (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME))
                            NIL))))
               (COMS (ADDTOCOMS (COND
                                       [(EQ (CADR COM)
                                            '*)
                                        (COND
                                           ((LITATOM (CADDR COM))
                                            (CADDR COM))
                                           (T (RETURN]
                                       (T (CDR COM)))
                            NAME TYPE NEAR LISTNAME))
               (DECLARE%: (AND (OR LISTNAME NEAR)
                               (ADDTOCOMS (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     ((LITATOM (CADDR COM))
                                                      (CADDR COM))
                                                     (T (RETURN]
                                                 (T (CDR COM)))
                                      NAME TYPE NEAR LISTNAME)))
               (CL:EVAL-WHEN (AND (OR LISTNAME NEAR)
                                  (ADDTOCOMS (COND
                                                    [(EQ (CL:THIRD COM)
                                                         '*)
                                                     (COND
                                                        ((LITATOM (CL:FOURTH COM))
                                                         (CL:FOURTH COM))
                                                        (T (RETURN]
                                                    (T (CDDR COM)))
                                         NAME TYPE NEAR LISTNAME)))
               ((PROP IFPROP) 
                    (SELECTQ TYPE
                        (PROPS (COND
                                  ((EQ (CADR COM)
                                       (CADR NAME))
                                   (ADDTOCOM1 (CDR COM)
                                          (CAR NAME)
                                          NEAR LISTNAME))
                                  ((AND (EQ (CAR NAME)
                                            (CADDR COM))
                                        (NULL (CDDDR COM)))
                                   [/RPLACA (CDR COM)
                                          (UNION (MKLIST (CDR NAME))
                                                 (MKLIST (CADR COM]
                                   (MARKASCHANGED COMSNAME 'VARS)
                                   T)))
                        (MACROS (COND
                                   ([AND (for PROP inside (CADR COM)
                                            always (EQMEMB PROP MACROPROPS))
                                         (for PROP in MACROPROPS
                                            always (OR (EQMEMB PROP (CADR COM))
                                                           (NOT (GETPROP NAME PROP]

                                    (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")

                                    (ADDTOCOM1 (CDR COM)
                                           NAME NEAR LISTNAME))))
                        NIL))
               ((PROPS ALISTS) 
                    (AND (EQ TYPE (CAR COM))
                         (ADDTOCOM1
                          COM
                          (/NCONC1 (OR [ASSOC (CAR NAME)
                                              (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     [(LITATOM (CADDR COM))
                                                      (AND (OR (NULL LISTNAME)
                                                               (EQ (CADDR COM)
                                                                   LISTNAME))
                                                           (GETTOPVAL (CADDR COM]
                                                     (T (RETURN]
                                                 (T (CDR COM]
                                       (LIST (CAR NAME)))
                                 (CADR NAME))
                          NEAR LISTNAME)))
               (P (COND
                     ((AND (EQ TYPE 'EXPRESSIONS)
                           (NEQ (CAR NAME)
                                'SETQ))
                      (ADDTOCOM1 COM NAME NEAR LISTNAME))))
               (AND (EQ (CAR COM)
                        TYPE)
                    (ADDTOCOM1 COM NAME NEAR LISTNAME])

(ADDTOCOM1
  [LAMBDA (COM NAME NEAR LISTNAME)                       (* rmk%: " 3-JAN-82 22:53")
    (COND
       [(EQ (CADR COM)
            '*)                                              (* ; "add to list name")
        (AND [COND
                (LISTNAME (EQ (CADDR COM)
                              LISTNAME))
                (T (LITATOM (CADDR COM]
             (SAVESET (CADDR COM)
                    [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM]
                           (COND
                              ((AND NEAR (SETQ NEAR (MEMBER NEAR COM)))
                               (/RPLACD NEAR (CONS NAME (CDR NEAR)))
                               COM)
                              (T (MERGEINSERT NAME COM T]
                    T
                    'NOPRINT]
       ((NULL LISTNAME)                                      (* ; "add to standard com")
        [AND (NOT (MEMBER NAME (CDR COM)))
             (COND
                [(SETQ NEAR (MEMBER NEAR COM))
                 (/RPLACD NEAR (CONS NAME (CDR NEAR]
                (T (/RPLACD COM (MERGEINSERT NAME (CDR COM]
        (MARKASCHANGED COMSNAME 'VARS)
        T])

(ADDNEWCOM
  [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE)             (* rmk%: " 3-JAN-82 22:53")

    (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE.  --- if LISTNAME is given, then use it as the listname")

    (PROG (NEWCOM OLDCOM TAIL)
          (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE))
          [COND
             ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME)))
              (RETURN (SAVESET COMSNAME (LIST NEWCOM)
                             T
                             'NOPRINT]
      LP  [COND
             ((OR (NLISTP (SETQ OLDCOM (CAR TAIL)))
                  (SELECTQ (CAR OLDCOM)
                      ((LOCALVARS SPECVARS BLOCKS) 
                           T)
                      (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM)))
                      NIL))
              (/ATTACH NEWCOM TAIL))
             ((LISTP (CDR TAIL))
              (SETQ TAIL (CDR TAIL))
              (GO LP))
             (T (/RPLACD TAIL (LIST NEWCOM]
          (MARKASCHANGED COMSNAME 'VARS])

(MAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* ; "Edited  8-Apr-87 14:55 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    (PROG (TEM)

     (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname")

          (AND (LISTP NAME)
               (SETQ NAME (COPY NAME)))
          (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE))
                           (APPLY* TEM NAME TYPE LISTNAME FILE))
                      (SELECTQ TYPE
                          (PROPS [AND (NULL LISTNAME)
                                      (CONS 'PROP (CONS (COND
                                                           ((AND (LISTP (CDR NAME))
                                                                 (NULL (CDDR NAME)))
                                                            (CADR NAME))
                                                           (T (CDR NAME)))
                                                        (OR (LISTP (CAR NAME))
                                                            (LIST (CAR NAME])
                          (EXPRESSIONS [COND
                                          ((EQ (CAR NAME)
                                               'SETQ)
                                           (MAKENEWCOM (CDR NAME)
                                                  'VARS LISTNAME FILE))
                                          (T (CONS 'P (COND
                                                         (LISTNAME (LIST '* LISTNAME))
                                                         (T (LIST NAME])
                          NIL)
                      (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE])

(DEFAULTMAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* lmm "20-OCT-82 22:48")
    (COND
       ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST)
                 (fetch MACRO of TYPE)
                 (fetch GETDEF of TYPE)))
        (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION
                                                                            of TYPE)
                                                                         TYPE)
               T))
       ((NULL DEFAULTCOMHASFILEFLG)                          (* ; "disable FOOFNS FOOVARS junk")
        (LIST TYPE NAME))
       ((EQ FILE T)                                          (* ; 
                                                           "FILE=T only when called from SHOWDEF")
        (LIST TYPE NAME))
       ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE))
                                      (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME))
                                             T)
                                      T
                                      'NOPRINT]              (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items")
        (LIST TYPE '* LISTNAME))
       (T (LIST TYPE NAME])
)

(RPAQ? DEFAULTCOMHASFILEFLG )

(ADDTOVAR MARKASCHANGEDFNS )
(DEFINEQ

(MERGEINSERT
  [LAMBDA (NEW LST ONEFLG)                               (* lmm "30-Jun-86 18:11")

    (* ;; "searches LST to find the most reasonable place to insert NEW.  Does nothing if ONEFLG is T and NEW is already a member of LST")

    (COND
       ((AND ONEFLG (MEMBER NEW LST))
        LST)
       ((LISTP NEW)
        (/NCONC1 LST NEW))
       (T (PROG ((N 0)
                 LST1 PLACE TEM)
                (SETQ LST1 LST)
            LP  

           (* ;; "finds the function with the longest leading common substring.  The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.")

                (COND
                   ((NULL LST1)
                    (GO OUT))
                   ((OR (LISTP (CAR LST1))
                        (SETQ TEM (STRPOS (CAR LST1)
                                         NEW 1 NIL T T)))

                    (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE")

                    (SETQ PLACE LST1)
                    (GO OUT))
                   ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1)
                                                NEW))
                           N)
                    (SETQ N TEM)
                    (SETQ PLACE LST1)))
                (SETQ LST1 (CDR LST1))
                (GO LP)
            OUT (SETQ TEM (CAR PLACE))
                (OR [SOME (OR PLACE LST)
                          (FUNCTION (LAMBDA (X LST)
                                      (COND
                                         ([OR (ALPHORDER NEW X)
                                              (AND PLACE (NOT (ALPHORDER TEM X]

                                 (* ;; "for example, if the FNS list is something like (...  FOO FOO1 ...) where the ...  may or may not be in order, e.g.  (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.")

                                          (/ATTACH NEW LST))
                                         (T (SETQ TEM X)
                                            NIL]
                    (SETQ LST (/NCONC1 LST NEW)))
                (RETURN LST])

(MERGEINSERT1
  [LAMBDA (X Y)                                          (* rmk%: "24-MAY-82 00:05")

    (* ;; "value is the number of leading characters of X and Y that agree.")

    (PROG ((N 1)
           C1 C2)
      LP  [COND
             ((OR (NULL (SETQ C1 (NTHCHARCODE X N)))
                  (NULL (SETQ C2 (NTHCHARCODE Y N)))
                  (NEQ C1 C2))
              (RETURN (SUB1 N]
          (SETQ N (ADD1 N))
          (GO LP])
)

(RPAQ? ADDTOFILEKEYLST
       [LIST '(%[ "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" 
                  NOECHOFLG T)
             (LIST (CHARACTER (CHARCODE ^J))
                   ""
                   'EXPLAINSTRING "{line-feed} - same as previous response" 'NOECHOFLG T)
             '(%  " %
-" EXPLAINSTRING "{space} - no action" NOECHOFLG T)
             '(%] "Nowhere%
-" EXPLAINSTRING "] - nowhere, item is marked as a dummy%
-" NOECHOFLG T)
             '[%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
                  (( "" CONFIRMFLG (%) %] %  %
-)
                      RETURN
                      (CDR ANSWER]
             '(@ "Near: " EXPLAINSTRING "@ other-item   -- put the item near the other item" 
                 NOECHOFLG T KEYLST (( "" CONFIRMFLG (%
-)
                                        RETURN ANSWER)))
             (LIST (CHARACTER (CHARCODE ^M))
                   ""
                   'RETURN
                   '% )
             '("" "File name: " EXPLAINSTRING "a file name" KEYLST (])

(RPAQ? LASTFILE )



(* ;; "deleting an item from a file")

(DEFINEQ

(DELFROMFILES
  [LAMBDA (NAME TYPE FILES)                              (* rmk%: " 6-MAR-82 13:16")

    (* ;; "Eliminates NAME as an item of type TYPE in COMS.")

    (PROG (COMS)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (RETURN (for FILE inside (OR FILES FILELST)
                     when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE))
                                            NAME TYPE)
                                  (COND
                                     ((INFILECOMS? NAME TYPE COMS)
                                      (printout T "(could not delete " NAME " from " FILE ")" T))))
                     collect (for FN in (fetch WHENUNFILED of TYPE)
                                    do (APPLY* FN NAME TYPE FILE))
                           FILE])

(DELFROMCOMS
  [LAMBDA (COMS NAME TYPE)                               (* bvm%: " 1-Oct-86 22:02")

    (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list).  Returns T if it does anything")

    (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.")

    (COND
       [(LITATOM COMS)
        (LET ((COMSNAME COMS))
             (DECLARE (SPECVARS COMS))
             (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME)))
                  (DELFROMCOMS COMS NAME TYPE]
       (T (PROG (DONE)
                (SETQ TYPE (GETFILEPKGTYPE TYPE))
            LP  (COND
                   ((NLISTP COMS)
                    (RETURN DONE)))
                [COND
                   ((LISTP (CAR COMS))
                    (SELECTQ (DELFROMCOM (CAR COMS)
                                    NAME TYPE)
                        (ALL (/RPLNODE2 COMS (CDR COMS))
                             (SETQQ DONE ALL)
                             (GO LP))
                        (NIL)
                        (SETQ DONE T)))
                   (T (SELECTQ (CAR COMS)
                          ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                               (SETQ COMS (CDR COMS)))
                          (COND
                             ((AND (EQ TYPE 'VARS)
                                   (EQ NAME (CAR COMS)))
                              (/RPLNODE2 COMS (CDR COMS))
                              (SETQ DONE T)
                              (GO LP]
                (SETQ COMS (CDR COMS))
                (GO LP])

(DELFROMCOM
  [LAMBDA (COM NAME TYPE)                                (* ; "Edited  2-May-87 19:02 by Pavel")
                                                             (* ; "Tries to delete NAME from COM")
    (PROG (TEM VAR NEW)
          (COND
             ((SETQ TEM (fetch DELETE of (CAR COM)))
              (AND (SETQ TEM (APPLY* TEM COM NAME TYPE))
                   (MARKASCHANGED COMSNAME 'VARS))
              (RETURN TEM)))
          (RETURN (SELECTQ (CAR COM)
                      ((DECLARE%: COMS) 
                           (DELFROMCOMS (COND
                                               [(EQ (CADR COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CADDR COM))
                                                    (CADDR COM))
                                                   (T (RETURN]
                                               (T (CDR COM)))
                                  NAME TYPE))
                      ((CL:EVAL-WHEN) 
                           (DELFROMCOMS (COND
                                               [(EQ (CL:THIRD COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CL:FOURTH COM))
                                                    (CL:FOURTH COM))
                                                   (T (RETURN]
                                               (T (CDDR COM)))
                                  NAME TYPE))
                      ((ALISTS PROPS) 
                           (AND (EQ TYPE (CAR COM))
                                (COND
                                   ((EQ (CADR COM)
                                        '*)
                                    (COND
                                       ([AND (LITATOM (SETQ VAR (CADDR COM)))
                                             (SETQ TEM (ASSOC (CAR NAME)
                                                              (GETTOPVAL VAR)))
                                             (NEQ (CDR TEM)
                                                  (SETQ TEM (REMOVEITEM (CADR NAME)
                                                                   (CDR TEM]
                                        (SAVESET VAR TEM T 'NOPRINT)
                                        T)))
                                   ([AND [CDR (SETQ TEM (ASSOC (CAR NAME)
                                                               (CDR COM]
                                         (NEQ (CDR TEM)
                                              (SETQ NEW (REMOVEITEM (CADR NAME)
                                                               (CDR TEM]
                                    (/RPLACD TEM NEW)
                                    (MARKASCHANGED COMSNAME 'VARS)
                                    T))))
                      (BLOCKS 
                              (* ;; "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")

                              [AND (EQ TYPE 'FNS)
                                   (for BLOCK in (INFILECOMTAIL COM T)
                                      do (AND (MEMB NAME BLOCK)
                                                  (/DREMOVE NAME BLOCK))
                                            (for X in BLOCK
                                               when (AND (LISTP X)
                                                             (MEMB NAME (CDR X)))
                                               do (/RPLACD X (REMOVE NAME (CDR X])
                      ((PROP IFPROP) 
                           [SELECTQ TYPE
                               (PROPS (RETURN (COND
                                                 ((EQ (CADR COM)
                                                      (CADR NAME))
                                                  (DELFROMCOM1 (CDR COM)
                                                         (CAR NAME)))
                                                 ((AND (EQMEMB (CADR NAME)
                                                              (CADR COM))
                                                       [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM]
                                                       (EQ (CAR TEM)
                                                           (CAR NAME)))
                                                  [/RPLACA (CDR COM)
                                                         (REMOVE (CADR NAME)
                                                                (MKLIST (CADR COM]
                                                  (MARKASCHANGED COMSNAME 'VARS)
                                                  T))))
                               (COND
                                  ([for PROP inside (CADR COM)
                                      always (EQ TYPE (GETPROP PROP 'PROPTYPE]
                                   (DELFROMCOM1 (CDR COM)
                                          NAME])
                      ((RECORDS INITRECORDS SYSRECORDS) 
                           (AND (EQ TYPE 'RECORDS)
                                (DELFROMCOM1 COM NAME)))
                      (P (AND (EQ TYPE 'EXPRESSIONS)
                              (DELFROMCOM1 COM NAME)))
                      ((VARS INITVARS) 
                           (AND (EQ TYPE 'VARS)
                                (DELFROMCOM1 COM NAME T)))
                      (AND (EQ TYPE (CAR COM))
                           (DELFROMCOM1 COM NAME])

(DELFROMCOM1
  [LAMBDA (COM NAME FLG)                                 (* rmk%: "10-JUN-82 22:44")

    (* ;; 
  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed")

    (LET (TEM VAL)
         (COND
            ((EQ (CADR COM)
                 '*)
             (COND
                ([AND (LITATOM (SETQ TEM (CADDR COM)))
                      (NEQ (SETQ VAL (GETTOPVAL TEM))
                           (SETQ VAL (REMOVEITEM NAME VAL FLG]
                 (SAVESET TEM VAL T 'NOPRINT)
                 T)))
            ((NEQ (CDR COM)
                  (SETQ TEM (REMOVEITEM NAME (CDR COM)
                                   FLG)))
             (/RPLACD COM TEM)
             (MARKASCHANGED COMSNAME 'VARS)
             T])

(REMOVEITEM
  [LAMBDA (X LST FLG)                                    (* ; "Edited 25-May-88 17:52 by drc:")
                                                             (* lmm "10-FEB-78 17:29")

    (* ;; 
  "returns a subset of LST with X deleted;  if FLG is set, also remove elements whose CAR is X")

    (COND
       [[OR (MEMBER X LST)
            (AND FLG (SOME LST (FUNCTION (LAMBDA (Y)
                                           (EQUAL (CAR (LISTP Y))
                                                  X]
        (SUBSET LST (FUNCTION (LAMBDA (Y)
                                (AND (NOT (EQUAL Y X))
                                     (OR (NOT FLG)
                                         (NLISTP Y)
                                         (NOT (EQUAL (CAR Y)
                                                     X]
       (T LST])

(MOVETOFILE
  [LAMBDA (TOFILE NAME TYPE FROMFILE)                    (* rmk%: "18-OCT-79 19:51")
                                                             (* ; "To move items between files")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    [COND
       ((OR (EQ TYPE 'FNS)
            FROMFILE)                                        (* ; 
       "FNS definition can reside on file if LOADFNS was done.  This guarantees that it is loaded.")
        (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM]
    (AND (EQ TYPE 'FNS)
         (MARKASCHANGED NAME TYPE))                      (* ; 
                                                   "FNS won't get dumped unless they are `changed'")
    (DELFROMFILES NAME TYPE FROMFILE)
    (ADDTOFILE NAME TYPE TOFILE])
)

(MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)

(MOVD? 'MOVETOFILE 'MOVEITEM NIL T)

(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)



(* ; "functions for doing things and marking them changed and auxiliary functions")

(DEFINEQ

(SAVEPUT
  [LAMBDA (ATM PROP VAL)                                 (* lmm " 7-May-84 16:56")

    (* ;; "analogous to SAVESET but also marks changed property lists;  LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT")

    [COND
       ((NOT (LITATOM ATM))
        (ERRORX (LIST 14 ATM]
    (PROG ((X (GETPROPLIST ATM))
           X0 TEM OLDFLG)
      LOOP
          (COND
             ((NLISTP X)
              (COND
                 ((AND (NULL X)
                       X0)                                   (* ; 
                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")
                  (SETQ TEM (LIST PROP VAL))
                  (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                        LISPXHIST))
                  (FRPLACD (CDR X0)
                         TEM)
                  (GO RET)))

              (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")

              )
             ((NLISTP (CDR X))

              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning.")

              )
             [(EQ (CAR X)
                  PROP)
              (SETQ OLDFLG (NEQ (EQUALN (CADR X)
                                       VAL 400)
                                T))                          (* ; "i.e. it probably changed")
              (/RPLACA (CDR X)
                     VAL)
              (COND
                 ((NOT OLDFLG)
                  (GO RET1))
                 (T (OR (EQ DFNFLG T)
                        (LISPXPRINT (LIST 'new PROP 'property 'for ATM)
                               T T))
                    (GO RET]
             (T (SETQ X (CDDR (SETQ X0 X)))
                (GO LOOP)))
          [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM]
          (SETPROPLIST ATM TEM)
          (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                LISPXHIST))
      RET (MARKASCHANGED (LIST ATM PROP)
                 'PROPS
                 (NOT OLDFLG))
      RET1
          (AND ADDSPELLFLG (ADDSPELL ATM 0))
          (RETURN VAL])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
    (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT))
)
(DEFINEQ

(UNMARKASCHANGED
  [LAMBDA (NAME TYPE)                                    (* JonL "24-Jul-84 19:59")

    (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties.  Value is name if anything is done")

    (PROG (ANYFLG)
          (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE
                                                                          TYPE
                                                                          'TYPE]
             while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL)
                                                               (SETQ ANYFLG T))
          [for F TAIL PROP TYPEDPROP in FILELST
             when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP
                                                    (ASSOC TYPE (fetch TOBEDUMPED
                                                                   of (SETQ PROP
                                                                           (fetch FILEPROP
                                                                              of F]
             do (SETQ ANYFLG T)
                   (COND
                      ((SETQ TAIL (REMOVE (CAR TAIL)
                                         (CDR TYPEDPROP)))
                       (/RPLACD TYPEDPROP TAIL))
                      (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP
                                                                              (fetch TOBEDUMPED
                                                                                 of PROP]
          (RETURN (AND ANYFLG NAME])

(PREEDITFN
  [LAMBDA (ATM TYPE EDITCHANGES)                         (* rmk%: "18-FEB-82 21:49")
                                                             (* ; 
                                           "EDITL is advised to call this before editing something")
    (AND FILEPKGFLG (SELECTQ TYPE
                        (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                   (CONS))
                                                            CLISPARRAY))
                                      (for X in (GETPROPLIST ATM)
                                         do (OR (NLISTP X)
                                                    (GETHASH X CLISPARRAY)
                                                    (PUTHASH X (CONS (CAR X)
                                                                     (CDR X))
                                                           CLISPARRAY]

                                 (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made")

                                 [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS)
                                                      EDITCHANGES
                                                      (APPEND (GETPROPLIST ATM])
                        (VARS [COND
                                 ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE))
                                  [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                    (CONS))
                                                             CLISPARRAY))
                                       (for X in (EVALV ATM)
                                          do (OR (NLISTP X)
                                                     (GETHASH X CLISPARRAY)
                                                     (PUTHASH X (CONS (CAR X)
                                                                      (CDR X))
                                                            CLISPARRAY]
                                  (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS)
                                                       EDITCHANGES
                                                       (for X in (EVALV ATM)
                                                          collect (CAR X])
                        NIL])

(POSTEDITPROPS
  [LAMBDA (EDITCHANGES OLDPROPS)                         (* rmk%: "18-FEB-82 21:50")
                                                             (* ; "was RESETSAVE'd from PREEDITFN")
    (PROG (OV FOUNDCHANGE)
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP)
                 when (for OLDPROP on OLDPROPS by (CDDR OLDPROP)
                             do (COND
                                       ((EQ (CAR OLDPROP)
                                            (CAR NEWPROP))   (* ; "Found the property")
                                        [AND (EQ (CADR OLDPROP)
                                                 (CADR NEWPROP))
                                             (COND
                                                ((NLISTP (CADR OLDPROP))
                                                             (* ; "value is same")
                                                 (RETURN))
                                                ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP)
                                                                                 CLISPARRAY))
                                                      (EQ (CAADR NEWPROP)
                                                          (CAR OV))
                                                      (EQ (CDADR NEWPROP)
                                                          (CDR OV)))
                                                 (PUTHASH (CADR NEWPROP)
                                                        NIL CLISPARRAY)
                                                             (* ; 
                                         "value has been edited (CLISPARRAY translation went away)")
                                                 (RETURN]
                                        (RETURN T))) finally 
                                                             (* ; "didn't find the property")
                                                           (RETURN T))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 (CAR NEWPROP))
                               'PROPS NIL)
                       (SETQ FOUNDCHANGE T))
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])

(POSTEDITALISTS
  [LAMBDA (EDITCHANGES OLDTOKENS)                        (* rmk%: " 4-JAN-82 10:14")
    (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES]
                                                             (* ; 
                                                           "called after an ALIST has been edited")
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 X)
                               'ALISTS NIL)
                       (SETQ FOUNDCHANGE T))
              [for NEWENTRY in NEWENTRIES
                 do (COND
                           ([AND (LISTP NEWENTRY)
                                 (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY))
                                           (EQ (CAR NEWENTRY)
                                               (CAR OV))
                                           (EQ (CDR NEWENTRY)
                                               (CDR OV]
                            (PUTHASH NEWENTRY NIL CLISPARRAY)
                            (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                     (CAR NEWENTRY))
                                   'ALISTS NIL)
                            (SETQ FOUNDCHANGE T]
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])
)

(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
                       (PUTPROP . SAVEPUT))



(* ; "sub-functions for file package commands & types")

(DEFINEQ

(ALISTS.GETDEF
  [LAMBDA (NAME TYPE OPTIONS)                            (* Pavel " 7-Oct-86 17:24")
    (AND (LISTP NAME)
         (CL:SYMBOLP (CAR NAME))
         (LET [(ASSOCIATION (ASSOC (CADR NAME)
                                   (GETTOPVAL (CAR NAME]
              (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME)
                                     ASSOCIATION])

(ALISTS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm "16-OCT-78 20:02")
                                                             (* ; 
                                          "called by MARKASCHANGED when an ALIST entry has changed")
    (PROG [(VARTYPE (GETPROP (CAR NAME)
                           'VARTYPE]
          (AND (LISTP VARTYPE)
               (EQ (CAR VARTYPE)
                   'ALIST)
               (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME)
                                              (CADR VARTYPE)
                                              NEWFLG])

(CLEARCLISPARRAY
  [LAMBDA (NAME TYPE REASON)
    (DECLARE (SPECVARS NAME TYPE REASON))            (* lmm "14-Aug-84 15:03")
    (AND CLISPARRAY (MAPHASH CLISPARRAY (COND
                                           [(EQ TYPE 'I.S.OPRS)
                                            (FUNCTION (LAMBDA (TRAN FORM)
                                                        (AND (MEMB NAME FORM)
                                                             (PUTHASH FORM NIL CLISPARRAY]
                                           (T                (* ; "MACRO changed")
                                              (FUNCTION (LAMBDA (TRAN FORM)
                                                          (COND
                                                             ((OR (EQ NAME (CAR FORM))
                                                                  (EQ (CAR (GETPROP (CAR FORM)
                                                                                  'CLISPWORD))
                                                                      'CHANGETRAN))
                                                              (PUTHASH FORM NIL CLISPARRAY])

(EXPRESSIONS.WHENCHANGED
  [LAMBDA (EXPR)                                         (* ; "Edited  6-Apr-87 20:21 by Pavel")
    (SELECTQ (CAR EXPR)
        ((SETQ SETQQ) 
             (UNMARKASCHANGED (CADR EXPR)
                    'VARS))
        ((PROGN PROG) 
             (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X)))
        NIL])

(MAKEALISTCOMS
  [NLAMBDA X                                             (* rmk%: "14-OCT-83 13:34")

    (* ;; "make command to dump prettydefmacros")

    (LIST
     (CONS 'ADDVARS
           (for PR in X
              join (for ALISTNAME inside (CAR PR)
                          collect (CONS ALISTNAME
                                            (for ATNAME inside (CDR PR) bind ENTRY
                                               when (SETQ ENTRY
                                                         (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME))
                                                             (PROGN (LISPXPRINT (LIST 'no ATNAME
                                                                                      'entry
                                                                                      'on ALISTNAME)
                                                                           T T)
                                                                    NIL))) collect ENTRY])

(MAKEFILESCOMS
  [NLAMBDA FILES                                         (* JonL "12-FEB-83 19:02")

    (* ;; "This scans the command just to warn the user about any errors.  Must match up with the big SELECTQ in FILESLOAD NIL")

    [for FILE in FILES
       do
       (OR
        (LITATOM FILE)
        (while (LISTP FILE)
           do (SELECTQ (CAR (OR (LISTP FILE)
                                    (RETURN)))
                      ((LOADCOMP LOADFROM))
                      (FROM (pop FILE)
                            (if (OR (EQ (CAR FILE)
                                            'VALUEOF)
                                        (if (AND (EQ (CAR FILE)
                                                         'VALUE)
                                                     (EQ (CADR FILE)
                                                         'OF))
                                            then (pop FILE)))
                                then (pop FILE)))
                      ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR))
                      (OR (FMEMB (CAR FILE)
                                 LOADOPTIONS)
                          (PRINT (CONS (CAR FILE)
                                       '(-- unrecognized FILES option))
                                 T)))
                 (pop FILE]
    (CONS 'FILESLOAD FILES])

(MAKELISPXMACROSCOMS
  [NLAMBDA X                                             (* lmm " 5-SEP-78 23:15")
    (PROG (TEM TEM2)
          (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                   LISPXHISTORYMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXHISTORYMACROS TEM)))
                                                       (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                          LISPXMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXMACROS TEM]
                        (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z LISPXCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2]
                                          (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z HISTORYCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2])

(MAKEPROPSCOMS
  [NLAMBDA X                                             (* lmm "26-FEB-78 17:10")

    (* ;; "make command to dump PROPS")

    (for PAIR in X collect (CONS 'PROP (CONS (COND
                                                            ((AND (LISTP (CDR PAIR))
                                                                  (NULL (CDDR PAIR)))
                                                             (CADR PAIR))
                                                            (T (CDR PAIR)))
                                                         (OR (LISTP (CAR PAIR))
                                                             (LIST (CAR PAIR])

(MAKEUSERMACROSCOMS
  [NLAMBDA X                                             (* rmk%: " 3-JAN-82 23:20")
    (PROG (TEM)
          [COND
             [X (for Y in X
                   do (OR (FASSOC Y USERMACROS)
                              (FASSOC Y EDITMACROS)
                              (LISPXPRINT (CONS Y '(-- no entry on USERMACROS))
                                     T T]
             (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR))
                               X]
          (RETURN (LIST (CONS 'ADDVARS
                              (NCONC (for VAR in '(USERMACROS EDITMACROS)
                                        when (SETQ TEM (for Y in (GETTOPVAL VAR)
                                                              when (FMEMB (CAR Y)
                                                                              X) collect Y))
                                        collect (CONS VAR TEM))
                                     (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS 
                                                                 DONTSAVEHISTORYCOMS)
                                        when [SETQ TEM
                                                  (SUBSET (GETTOPVAL LST)
                                                         (FUNCTION (LAMBDA (Y)
                                                                     (OR (FMEMB Y X)
                                                                         (AND (LISTP Y)
                                                                              (FMEMB (CAR Y)
                                                                                     X]
                                        collect (CONS LST TEM])

(PROPS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm " 7-SEP-78 22:08")
    (PROG [(PROPTYPE (GETPROP (CADR NAME)
                            'PROPTYPE]
          (COND
             [PROPTYPE (RETFROM 'MARKASCHANGED (COND
                                                  ((NEQ PROPTYPE 'IGNORE)
                                                   (MARKASCHANGED (CAR NAME)
                                                          PROPTYPE NEWFLG]
             (T (SELECTQ (CADR NAME)
                    (CLISPWORD (CLEARCLISPARRAY (CAR NAME)))
                    NIL])

(FILEGETDEF.LISPXMACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:12")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (EQ FIRST 'ADDTOVAR)
                                                                   (MEMB SECOND '(LISPXMACROS 
                                                                                        LISPXCOMS))
                                                                   T]
                when (SELECTQ (CADR X)
                             (LISPXMACROS                    (* ; 
                      "Rebuild the expressions cause there might be other elements in the ADDTOVAR")
                                          (AND (SETQ X (ASSOC NAME (CDDR X)))
                                               (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X))))
                             (LISPXCOMS [COND
                                           ((MEMB NAME (CDDR X))
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME)))
                                           ((SETQ X (ASSOC NAME (CDDR X)))
                                                             (* ; "For synonym pairs")
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X])
                             NIL) collect X])

(FILEGETDEF.ALISTS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'ADDTOVAR)
                                                          (EQ SECOND (CAR NAME]
       when (SETQ X (ASSOC (CADR NAME)
                               (CDDR X))) collect X
       finally (RETURN (COND
                              ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.RECORDS
  [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND)            (* lmm "26-Jun-86 15:56")
    (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                              (AND (MEMB FIRST CLISPRECORDTYPES)
                                                   (OR (EQ SECOND NAME)
                                                       (AND (MEMB SECOND '(%( %[))
                                                            (PROGN (RATOM)
                                                                   (RATOM)
                                                                   (RATOM)
                                                                   (EQ NAME (RATOM]
         (if (EQ (CAAR VAL)
                     'NOT-FOUND%:)
             then NOTFOUND
           elseif (CDR VAL)
             then (CONS 'PROGN VAL)
           else (CAR VAL])

(FILEGETDEF.PROPS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'PUTPROPS)
                                                          (EQ SECOND (CAR NAME]
       join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL)
                                                                              (CADR NAME))
                   join (LIST (CAR TAIL)
                                  (CADR TAIL)))
       finally (RETURN (COND
                              ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.MACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "28-May-86 09:51")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (FMEMB FIRST '(PUTPROPS DEFMACRO))
                                                                   (EQ SECOND NAME]
                join (if (EQ (CAR X)
                                     'DEFMACRO)
                             then (LIST X)
                           else (for TAIL on (CDDR X) by (CDDR TAIL)
                                       when (FMEMB (CAR TAIL)
                                                       MACROPROPS) collect (LIST 'PUTPROPS
                                                                                     (CADR X)
                                                                                     (CAR TAIL)
                                                                                     (CADR TAIL])

(FILEGETDEF.VARS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:14")
    (for X in (LOADFNS NIL SOURCE 'GETDEF NAME)
       do (SELECTQ (CAR X)
                  ((RPAQQ SETQQ) 
                       (RETURN (CADDR X)))
                  ((RPAQ SETQ RPAQ?) 
                       (RETURN (EVAL (CADDR X))))
                  NIL) finally (RETURN 'NOBIND])

(FILEGETDEF.FNS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: "29-Aug-86 22:30")
    (LET (MAP ENV)
         (COND
            [(AND (EQMEMB 'FAST OPTIONS)
                  (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
                                (GET-ENVIRONMENT-AND-FILEMAP SOURCE))
                         MAP))
             (for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME
                                                                                      (CDDR PAIR]
                do [OR (OPENP SOURCE)
                           (RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
                                                                             'OLD]
                      (SETFILEPTR SOURCE MAPLOC)
                      (RETURN (WITH-READER-ENVIRONMENT ENV
                                  [COND
                                     ((EQMEMB 'ARGLIST OPTIONS)
                                      (RATOM SOURCE)
                                      (READ SOURCE)
                                      (RATOM SOURCE)
                                      (LIST (READ SOURCE)
                                            (READ SOURCE)))
                                     (T (CADR (READ SOURCE])]
            (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])

(FILEPKGCOMS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 11:29")
    (PROG (COM TYP)
          [SELECTQ (CAR (LISTP DEFINITION))
              (COM (SETQ COM (CDR DEFINITION)))
              (TYPE (SETQ TYP (CDR DEFINITION)))
              (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION)))
                     (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION]

     (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE")

          (for I in COM by (CDDR I) do (SELECTQ I
                                                           ((ADD DELETE MACRO CONTENTS CONTAIN COM))
                                                           (ERROR I 
                                                                  "not file package command property"
                                                                  )))
                                                             (* ; 
                                                   "COM merely adds to spelling list, for builtins")
          [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS)
                                             (LISTGET COM 'CONTAIN]
                                                             (* ; "Until CONTAIN is de-documented.")
          (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP
                                                                         (LISTGET COM PROP)))
          [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS)
                                                           (SELECTQ I
                                                               ((DESCRIPTION TYPE))
                                                               (ERROR I 
                                                             "not file package type/command property"
                                                                      ]
                                                             (* ; 
                                                  "TYPE merely adds to spelling list, for builtins")
          (for PROP in (UNION '(DESCRIPTION TYPE)
                                      FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP
                                                                      (LISTGET TYP PROP])

(FILES.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 17:13")
    (PROGN (PUTDEF (FILECOMS NAME)
                  'VARS
                  (CAR DEFINITION)
                  REASON)                                    (* ; "DEFINE THE COMS")
           (ADDFILE NAME)                                (* ; 
                                                           "MAKE SURE IT IS A FILE PACKAGE ENTITY")
           [/replace TOBEDUMPED of (fetch FILEPROP of NAME)
                                          (FILEPKG.MERGECHANGES (CADR DEFINITION)
                                                 (fetch TOBEDUMPED of (fetch FILEPROP
                                                                                 of NAME]
           (OR (fetch FILEDATES of NAME)
               (/replace FILEDATES of NAME with (CADDR DEFINITION])

(VARS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "29-Jul-85 20:59")
    (/SETTOPVAL NAME DEFINITION T])

(FILES.WHENCHANGED
  [LAMBDA (NAME TYPE REASON)
    (MARKASCHANGED (FILECOMS NAME)
           'VARS REASON])
)

(ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO)

(ADDTOVAR SYSPROPS PROPTYPE)

(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)

(PUTPROPS SUBR PROPTYPE IGNORE)

(PUTPROPS LIST PROPTYPE IGNORE)

(PUTPROPS CODE PROPTYPE IGNORE)

(PUTPROPS FILEDATES PROPTYPE IGNORE)

(PUTPROPS FILE PROPTYPE IGNORE)

(PUTPROPS FILEMAP PROPTYPE IGNORE)

(PUTPROPS EXPR PROPTYPE FNS)

(PUTPROPS VALUE PROPTYPE VARS)

(PUTPROPS COPYRIGHT PROPTYPE FILES)

(PUTPROPS FILETYPE PROPTYPE FILES)

(PUTPROPS BAKTRACELST VARTYPE ALIST)

(PUTPROPS BREAKMACROS VARTYPE ALIST)

(PUTPROPS COMPILETYPELST VARTYPE ALIST)

(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))

(PUTPROPS ERRORTYPELST VARTYPE ALIST)

(PUTPROPS FONTDEFS VARTYPE ALIST)

(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))

(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)

(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)

(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)

(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))



(* ; "Define the commands below AFTER the various properties have been established.")


(ADDTOVAR USERMACROS
          (M NIL (MAKE FILE FILE))
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITMACROS
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITCOMSA M)

(ADDTOVAR EDITCOMSL M)



(* ; "GETDEF methods")

(DEFINEQ

(RENAME
  [LAMBDA (OLD NEW TYPES FILES METHOD)               (* JonL "24-Jul-84 20:01")
    (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD)))

     (* ;; "special kludge: change the callers BEFORE if we are changing a field;  this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message")

          [for TYPE inside TYPES when (NEQ TYPE 'FIELDS)
             do (COPYDEF OLD NEW TYPE NIL (COND
                                                     ((EQ TYPE 'VARS)
                                                      'NOERROR]
          (CHANGECALLERS OLD NEW TYPES FILES METHOD)
          [for TYPE inside TYPES do (COND
                                                   ((AND (EQ TYPE 'FIELDS)
                                                         (HASDEF OLD 'FIELDS))

                                 (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file.  Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.")

                                                    (COPYDEF OLD NEW 'FIELDS))
                                                   (T (DELDEF OLD TYPE]
          (RETURN NEW])

(CHANGECALLERS
  [LAMBDA (OLD NEW AS-TYPES FILES METHOD)            (* ; "Edited  6-Dec-86 01:25 by lmm")
    (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES))
           REL TEM EDITCOMS FNS)
          (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD))
          [SETQ EDITCOMS
           (LIST (COND
                    [(OR (EQMEMB 'CAREFUL METHOD)
                         (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES))
                                (printout T "Warning --" OLD " is also defined as " TEM T)))

                     (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename.  Y means do it, No means skip, anything else goes into TTY.")

                     (SUBPAIR '(OLD NEW)
                            (LIST OLD NEW)
                            '(BIND (LPQ (F OLD N)
                                            (MARK %#1)
                                            (ORR (1 !0 P)
                                                 NIL)
                                            (MARK %#2)
                                            (COMS (SELECTQ (ASKUSER NIL NIL "   Replace ? "
                                                                  '((Y "Yes
")
                                                                    (N "No
")
                                                                    (%
 "")
                                                                    (%  "")
                                                                    (%
 "")
                                                                    (& ""))
                                                                  NIL NIL '(NOECHOFLG T))
                                                      (Y '(R1 OLD NEW))
                                                      (N NIL)
                                                      'TTY%:))
                                            (MARK %#3)
                                            (IF (EQ (%## (\ %#3))
                                                        (%## (\ %#2)))
                                                   ((\ %#1))
                                                   NIL]
                    (T (LIST 'R OLD NEW]
          (SELECTQ (COND
                      ((AND (EQMEMB 'MASTERSCOPE METHOD)
                            MSDATABASELST
                            (for TYPE inside AS-TYPES
                               do [COND
                                         ((SETQ TEM (SELECTQ TYPE
                                                        ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 
                                                             'CALL)
                                                        (MACROS '(CALL DIRECTLY))
                                                        ((VARS VARIABLES) 
                                                             '(USE OR BIND))
                                                        ((RECORDS FIELDS I.S.OPRS) 
                                                             (LIST 'USE 'AS TYPE))
                                                        (RETURN NIL)))
                                          (COND
                                             (REL (SETQ REL (LIST TEM 'OR REL)))
                                             (T (SETQ REL TEM] FINALLY (RETURN REL)))

                       (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known")

                       'MASTERSCOPE)
                      ((EQMEMB 'EDITCALLERS METHOD)
                       'EDITCALLERS)
                      (T 'SEARCH))
              (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND
                                                     ((NULL FILES)
                                                      (UPDATEFILES)
                                                      (FILEPKGCHANGES 'FNS]
                                                  (for FILE inside (OR FILES FILELST)
                                                     join (FILEFNSLST FILE]
                                 (FUNCTION UPDATEFN))
                           (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL))
                                                          T)
                                            FNS)))
              (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST)
                                          when (SETQ TEM (EDITCALLERS OLD X T))
                                          collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM)))
                                                             X))))
              (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST
                                                                                   X))))
              (ERROR "UNRECOGNIZED RENAME METHOD" METHOD))
          (AND (EQMEMB 'FNS AS-TYPES)
               (FMEMB OLD FNS)
               (SETQ FNS (REMOVE OLD FNS)))
          (EDITFROMFILE FNS FILES OLD EDITCOMS)
          [for TYPE inside AS-TYPES
             do (for FILE in (WHEREIS OLD TYPE FILES)
                       do (AND (ADDTOFILE NEW TYPE FILE)
                                   (DELFROMFILES OLD TYPE FILE)
                                   (printout T OLD " changed to " NEW " on " FILE)))
                   (COND
                      ((SETQ TEM (WHEREIS OLD TYPE FILES))
                       (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM]
          (COND
             (REL (UPDATECHANGED)
                  (COND
                     ((AND (SETQ TEM (GETRELATION OLD REL T))
                           (WHEREIS TEM 'FNS FILES))
                      (printout T "Couldn't find where " OLD " is referenced in " TEM T])
)
(DEFINEQ

(SHOWDEF
  [LAMBDA (NAME TYPE FILE)                              (* ; "Edited 16-Apr-2018 21:35 by rmk:")
                                                             (* ; 
                                                 "prettyprint NAME as it would be dumped as a TYPE")
    (RESETLST
        (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
              (DECLARE (SPECVARS . T))
              [AND FILE (NEQ FILE (OUTPUT))
                   (if (SETQ FL (OPENP FILE 'OUTPUT))
                       then (RESETSAVE (OUTPUT FL))
                     else (OUTFILE FILE)
                           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                                (OUTPUT]
              (PRETTYCOM (MAKENEWCOM NAME TYPE))))])

(COPYDEF
  [LAMBDA (OLD NEW TYPE SOURCE OPTIONS)              (* lmm "14-Aug-84 18:38")
                                                             (* ; "like MOVD, but takes a type.")
    (PROG (TEM DEF)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          [SETQ DEF (GETDEF OLD TYPE SOURCE (COND
                                                   ((EQ OPTIONS 'NOCOPY)
                                                    NIL)
                                                   (T (REMOVE 'NOCOPY (MKLIST OPTIONS]
                                                             (* ; 
      "The default is for GETDEF to return a COPY.  Make sure that NOCOPY isn't in options though.")
          (SELECTQ TYPE
              (VARS)
              (FILES [for X in (CAR DEF)
                        do                               (* ; 
                                          "change all the listnames which are of form filenameTYPE")
                              (SELECTQ (CAR X)
                                  ((PROP IFPROP) 
                                       (SETQ X (CDR X)))
                                  NIL)
                              (COND
                                 ((EQ (CADR X)
                                      '*)
                                  (SETQ X (CDDR X))
                                  (COND
                                     ((AND (LITATOM (CAR X))
                                           (SETQ TEM (STRPOS OLD (CAR X)
                                                            1 NIL T T)))
                                      (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X)
                                                                           TEM -1)))
                                             (COPY (GETTOPVAL (CAR X)))
                                             T)
                                      (FRPLACA X TEM])
              ((PROPS ALISTS) 
                   (OR (EQ (CAR NEW)
                           (CAR OLD))
                       (DSUBST (CAR NEW)
                              (CAR OLD)
                              DEF))
                   (OR (EQ (CADR NEW)
                           (CADR OLD))
                       (DSUBST (CADR NEW)
                              (CADR OLD)
                              DEF)))
              (DSUBST NEW OLD DEF))
          (PUTDEF NEW TYPE DEF)
          (RETURN NEW])

(GETDEF
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "13-Jul-85 04:10")

    (* ;; "returns the definition of NAME as a TYPE from SOURCE;  cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found.  The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.")

    (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS)))
          (DECLARE (SPECVARS NOCOPY))
          (SELECTQ OPTIONS
              (0 (SETQQ OPTIONS (NOERROR NODWIM))
                 (SETQ NOCOPY T))
              (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST))
                 (SETQ NOCOPY T))
              (T (SETQQ OPTIONS SPELL))
              NIL)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          (SELECTQ SOURCE
              (0 (SETQQ SOURCE CURRENT))
              (T (SETQQ SOURCE SAVED))
              (NIL (SETQQ SOURCE ?))
              NIL)
          [SELECTQ SOURCE
              (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS)))
              (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS]
                      (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS])
              (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS)))
              (COND
                 ((AND (LISTP SOURCE)
                       (EQ (CAR SOURCE)
                           '=))
                  (SETQ DEF (CDR SOURCE)))
                 (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS))
                    (SETQ NOCOPY T]
          (OR NOCOPY (SETQ DEF (COPY DEF)))
          (COND
             ((AND (EQ TYPE 'FNS)
                   (NOT (EQMEMB 'NODWIM OPTIONS)))
              (DWIMDEF DEF NAME SOURCE)))
          (RETURN DEF])

(GETDEFCOM
  [LAMBDA (X)                                            (* lmm " 4-Jul-85 13:31")

    (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in.  Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed.  --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.  That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.")
                                                             (* ; "a RETFROM point")
    (for Y in X join (GETDEFCOM0 Y])

(GETDEFCOM0
  [LAMBDA (COM)                                          (* wt%: " 7-FEB-79 23:28")
    (PROG (TEM)
          (RETURN (COND
                     ((SETQ TEM (fetch MACRO of (CAR COM)))
                                                             (* COND ((fetch CONTENTS of
                                                           (CAR COM)) (* ; 
                        "if it has a CONTENTS function, generally means it is not safe to evaluate")
                                                           (RETFROM (QUOTE GETDEFCOM))))
                      (for Y in (SUBPAIR (CAR TEM)
                                               (PRETTYCOM1 COM)
                                               (CDR TEM)) join (GETDEFCOM0 Y)))
                     (T (SELECTQ (CAR COM)
                            (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X)))
                            (ADDVARS (for Y in (PRETTYCOM1 COM)
                                        collect (CONS 'ADDTOVAR Y)))
                            (APPENDVARS (for Y in (PRETTYCOM1 COM)
                                           collect (CONS 'APPENDTOVAR Y)))
                            (P (APPEND (PRETTYCOM1 COM)))
                            (RETFROM 'GETDEFCOM])

(GETDEFCURRENT
  [LAMBDA (NAME TYPE OPTIONS)                            (* ; "Edited  2-May-87 19:00 by Pavel")
                                                             (* ; 
                                                           "Gets the current definition--source=0")
    (LET
     (DEF)
     (COND
        ((AND (SETQ DEF (fetch GETDEF of TYPE))
              (NEQ DEF T))

         (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")

         (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS))
                  (fetch NULLDEF of TYPE))
             (GETDEFERR NAME TYPE OPTIONS))
         DEF)
        (T
         (OR
          (NEQ
           [SETQ DEF
            (SELECTQ TYPE
                (FNS (AND (LITATOM NAME)
                          (EXPRP (SETQ DEF (VIRGINFN NAME)))
                          DEF))
                (VARS (if (LITATOM NAME)
                          then (GETTOPVAL NAME)
                        else 'NOBIND))
                ((FIELDS RECORDS) 
                     (if (LITATOM NAME)
                         then [SETQ DEF (SELECTQ TYPE
                                                (RECORDS (RECLOOK NAME))
                                                (MKPROGN (FIELDLOOK NAME]
                               (if (EQMEMB 'EDIT OPTIONS)
                                   then (COPY DEF)
                                 else DEF)))
                (FILES                                       (* ; 
              "what is the `definition' of a file?  -- I guess the COMS which say what it contains")
                       [if (LITATOM NAME)
                           then (if (SETQ DEF (GETFILEDEF NAME))
                                        then (UPDATEFILES)
                                              (LIST (LISTP (GETTOPVAL (FILECOMS DEF)))
                                                    (fetch TOBEDUMPED
                                                       of (fetch FILEPROP of DEF))
                                                    (LISTP (fetch FILEDATES of DEF])
                (TEMPLATES (if (AND (LITATOM NAME)
                                        (SETQ DEF (GETTEMPLATE NAME)))
                               then (LIST 'SETTEMPLATE (KWOTE NAME)
                                              (KWOTE DEF))))
                (MACROS [if [AND (LITATOM NAME)
                                     (SETQ DEF (for X on (GETPROPLIST NAME)
                                                  by (CDDR X) when (FMEMB (CAR X)
                                                                                  MACROPROPS)
                                                  join (LIST (CAR X)
                                                                 (CADR X]
                            then `(PUTPROPS ,NAME ,@DEF])
                (EXPRESSIONS (LISTP NAME))
                (PROPS [AND (LISTP NAME)
                            (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME))
                                                 [FUNCTION (LAMBDA (X)
                                                             (EQ X (CADR NAME]
                                                 (FUNCTION CDDR)))
                                 (LIST 'PUTPROPS (CAR NAME)
                                       (CADR NAME)
                                       (CADR DEF])
                (FILEPKGCOMS [AND (LITATOM NAME)
                                  (PROG ((COM (FILEPKGCOM NAME))
                                         (TYP (FILEPKGTYPE NAME)))
                                        (RETURN (COND
                                                   ((AND COM TYP)
                                                    (LIST (CONS 'COM COM)
                                                          (CONS 'TYPE TYP)))
                                                   (COM (LIST (CONS 'COM COM)))
                                                   (TYP (LIST (CONS 'TYPE TYP])
                (FILEVARS (COND
                             ((AND (LITATOM NAME)
                                   (LISTP (SETQ DEF (GETTOPVAL NAME)))
                                   (WHEREIS NAME 'FILEVARS))
                              DEF)
                             (T 'NOBIND)))
                (LET
                 ((COMS (LIST (MAKENEWCOM NAME TYPE)))
                  FILE)
                 [COND
                    ((NOT (SETQ DEF (GETDEFCOM COMS)))
                     (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
                         (RESETLST
                             (RESETSAVE PRETTYFLG)
                             (RESETSAVE FONTCHANGEFLG)
                             [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
                             (PRETTYDEFCOMS COMS)
                             (SETFILEPTR FILE 0)
                             [SETQ DEF
                              (for X in (READFILE FILE)
                                 join
                                 (SELECTQ (CAR X)
                                     ((*) 
                                          NIL)
                                     (DECLARE%: (for Y on (CDR X)
                                                   unless (SELECTQ (CAR Y)
                                                                  ((COPYWHEN EVAL@LOADWHEN 
                                                                          EVAL@COMPILEWHEN) 
                                                                       (RETURN (LIST Y)))
                                                                  (FMEMB (CAR Y)
                                                                         DECLARETAGSLST))
                                                   collect (CAR Y)))
                                     (CL:EVAL-WHEN (CDDR X))
                                     (PROGN (CDR X))
                                     (LIST X]
                             (SETQ NOCOPY T)))]
                 (MKPROGN DEF]
           (fetch NULLDEF of TYPE))
          (GETDEFERR NAME TYPE OPTIONS))
         DEF])

(GETDEFERR
  [LAMBDA (NAME TYPE OPTIONS MSG)                        (* lmm "13-Jul-85 04:11")
    (DECLARE (USEDFREE NODEF))                           (* ; 
                                       "Message non-null if looking for saved or filed definition.")
    (PROG (TEM)
          (RETURN (COND
                     ((EQMEMB 'NOERROR OPTIONS)              (* ; 
                                               "We want to do the string search in the HASDEF case")
                      (RETURN (fetch NULLDEF of TYPE)))
                     [(AND (NULL MSG)
                           (EQMEMB 'SPELL OPTIONS)
                           (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS)
                                                                          'SPELL)
                                                                   T)))
                           (NEQ TEM NAME))
                      (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS]
                     (T (for O inside OPTIONS when (STRINGP O)
                           do (RETFROM 'GETDEF O)
                           finally (ERROR NAME (CONS TYPE '(definition not found))
                                              T])

(GETDEFFROMFILE
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: " 1-Oct-86 22:10")

    (* ;; "Tries to get definition from source file.  If successful, returns the definition.  Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.")

    (DECLARE (SPECVARS NAME))
    (bind (NOTFOUND _ "not found")
           DEF SOURCE TEM2 for FILE inside (COND
                                                      ((EQ SOURCE 'FILE)
                                                       (WHEREIS NAME TYPE T))
                                                      (T SOURCE))
       when
       (AND
        (SETQ SOURCE (FINDFILE FILE T))
        (NEQ
         [SETQ DEF
          (COND
             ((SETQ TEM2 (fetch FILEGETDEF of TYPE))
              (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND))
             (T
              (SELECTQ TYPE
                  (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  ((VARS FILEVARS) 
                       (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (COND
                     [(SETQ DEF (GET TYPE 'DEFINERS))
                      (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF
                                        `(LAMBDA (FIRST SECOND)
                                           (AND (MEMB FIRST ',DEF)
                                                (OR (EQ SECOND NAME)
                                                    (AND (MEMB SECOND '(%( %[))
                                                         (PROGN (RATOM)
                                                                (RATOM)
                                                                (RATOM)
                                                                (EQ NAME (RATOM]
                                                             (* ; "ick!  Should use real closure")
                           (if (EQ (CAAR VAL)
                                       'NOT-FOUND)
                               then NOTFOUND
                             elseif (CDR VAL)
                               then (CONS 'PROGN VAL)
                             else (CAR VAL]
                     (T (RESETLST
                            (RESETSAVE (RESETUNDO))
                            [LET (LOAD-VERBOSE-STREAM)
                                 (DECLARE (SPECVARS LOAD-VERBOSE-STREAM))
                                                             (* ; 
                                                     "just in case we get a PRETTYCOMPRINT in here")
                                 (LOADFNS NIL SOURCE 'PROP (COND
                                                              ((LITATOM NAME)
                                                             (* ; 
                                         "If an atom, only bother with expressions that contain it")
                                                               (CONS (LIST '& '|..| NAME)))
                                                              (T T]
                            (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))]
         NOTFOUND)) do (AND (EQ SOURCE 'FILE)
                                (OR (FMEMB FILE FILELST)
                                    (CL:FORMAT T "(from ~A)~%%" SOURCE))) 
                                                             (* ; 
                                                        "Copying and dwimifying are done in GETDEF")
                          (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
                                                                  (APPEND '(no definition on)
                                                                         (MKLIST SOURCE])

(GETDEFSAVED
  [LAMBDA (NAME TYPE OPTIONS)                          (* ; "Edited 11-Aug-87 18:14 by cutting")
                                                             (* ; 
                                                           "Gets the `saved' definition--source=T")
    (SELECTQ TYPE
        (FNS (OR (GETPROP NAME 'EXPR)
                 (GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
        (VARS                                                (* ; 
                               "The value of a variable is never substituted into and never COPIED")
              (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
                                                                                'VALUE)
                 do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS 
                                                                     "no saved value for "))))
        (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS)))
            (GETDEFERR NAME TYPE OPTIONS "no saved definition for "])

(PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* ; "Edited  8-Apr-87 12:52 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE)))
         (COND
            (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON))
            (T (SELECTQ TYPE
                   (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON))
                   (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON))
                   (EVAL DEFINITION))
               NAME])

(EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)
    (DECLARE (LOCALVARS . T)
           (SPECVARS SOURCE))                          (* ; "Edited 27-Jul-87 11:04 by cutting")

    (* ;; "lets you edit anything.  Given name and type, call editor on the definition (loading it in from SOURCE if necessary).  If you change it, then the definition gets unsaved.  OPTIONS is passed through from ED to the editor.")

    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (COND
       ((AND (fetch EDITDEF of TYPE)
             (APPLY* (fetch EDITDEF of TYPE)
                    NAME TYPE SOURCE EDITCOMS OPTIONS)))
       ((AND (EQ TYPE 'FNS)
             (NULL SOURCE))                                  (* ; 
                                "special hack for EDITDEF of FNS because of ability to EDITLOADFNS")
        (EDITDEF.FNS NAME EDITCOMS OPTIONS))
       (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))
    NAME])

(DEFAULT.EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 11-Jun-92 16:26 by cat")
    (PROG [(DEF (COND
                   [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
                   [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
                   [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
                   (T (LET ((FILES (WHEREIS NAME TYPE T)))
                           (CL:IF (NULL FILES)
                               (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE)
                               [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME 
                                                         FILES)
                                                  (CL:IF (CL:ENDP (CDR FILES))
                                                      (CL:IF (CL:Y-OR-N-P 
                                                                    "Shall I load this file PROP? ")
                                                             (CAR FILES))
                                                      (ASKUSER NIL NIL 
                                                             "indicate which file to load PROP: "
                                                             (MAKEKEYLST FILES)
                                                             T))]
                                    (CL:WHEN FILE
                                        (LOAD FILE 'PROP)
                                        (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])]

     (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")

          (DECLARE (SPECVARS RETRY))

     (* ;; "what is RETRY ???")

          (SETQ RETRY)
          (CL:WHEN DEF
              (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
                                                             (* ; 
                                             "this function is called when there were changes made")
                                                        (FIXEDITDATE DEF)
                                                             (* ; "fix the edit date first - jtm")
                                                        (PUTDEF NAME TYPE DEF)
                                                        (MARKASCHANGED NAME TYPE 'CHANGED)

                                 (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition.  doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here.  this sometimes results in MARKASCHANGED getting called twice.")

                                                        ]
                     OPTIONS))])

(EDITDEF.FILES
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 18-Mar-87 16:07 by woz")
    (EDITDEF (FILECOMS NAME)
           'VARS SOURCE EDITCOMS OPTIONS])

(LOADDEF
  [LAMBDA (NAME TYPE SOURCE)                             (* lmm "13-SEP-78 01:34")
    (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY])

(DWIMDEF
  [LAMBDA (DEF FN SOURCE)                                (* lmm " 6-Jun-86 17:23")
    (AND [OR (EQ DWIMIFYCOMPFLG T)
             (EQ CLISPIFYPRETTYFLG T)
             (EQ (CAR (CADDR DEF))
                 'CLISP%:)
             (SELECTQ SOURCE
                 ((CURRENT SAVED FILE ?) 
                      NIL)
                 (AND (LITATOM SOURCE)
                      (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE]
         (LET ((NOSPELLFLG T)
               (DWIMESSGAG T)
               FILEPKGFLG LISPXHIST)
              (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST))
              (DWIMIFY0 DEF (COND
                               ((OR (LISTP FN)
                                    (NULL FN))
                                '?)
                               (T FN))
                     NIL DEF])

(DELDEF
  [LAMBDA (NAME TYPE)                                    (* ; "Edited  5-Dec-86 06:20 by lmm")
    (PROG (TEM)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
      LP  [COND
             ((SETQ TEM (fetch DELDEF of TYPE))
              (APPLY* TEM NAME TYPE))
             (T (SELECTQ TYPE
                    (FNS                                     (* ; 
  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such")
                         (AND (EXPRP NAME)
                              (/PUTD NAME))
                         (REMPROP NAME 'EXPR)
                         [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME])
                    (VARS (/SETTOPVAL NAME 'NOBIND))
                    (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES)
                              do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST]
                           (/replace FILEPROP of NAME with NIL)
                           (/replace FILECHANGES of NAME with NIL)
                           (/replace FILEDATES of NAME with NIL)
                           (FLUSHFILEMAPS NAME))
                    (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME)
                                 (DELFROMLIST 'FILEPKGTYPES NAME)
                                 (for FIELD on (FILEPKGCOM NAME)
                                    by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD)
                                                                      NIL))
                                 (for FIELD on (FILEPKGTYPE NAME)
                                    by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD)
                                                                      NIL))
                                 (/replace ALLFIELDS of NAME with NIL))
                    (ALISTS [AND (LISTP NAME)
                                 (DELFROMLIST (CAR NAME)
                                        (FASSOC (CADR NAME)
                                               (GETTOPVAL (CAR NAME])
                    (MACROS (for P in MACROPROPS do (/REMPROP NAME P)))
                    (PROPS (AND (LISTP NAME)
                                (/REMPROP (CAR NAME)
                                       (CADR NAME))))
                    (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS))
                                 (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS
                                                                             ))
                                 (DELFROMLIST 'LISPXCOMS NAME)
                                 (DELFROMLIST 'HISTORYCOMS NAME))
                    (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet")
                           T]
          (MARKASCHANGED NAME TYPE 'DELETED)
          (RETURN NAME])

(DELFROMLIST
  [LAMBDA (VAR VAL)                                      (* rmk%: " 3-JAN-82 23:22")
    (AND (FMEMB VAL (GETTOPVAL VAR))
         (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR)
                                (FUNCTION (LAMBDA (X)
                                            (AND (NEQ X VAL)
                                                 (OR (NLISTP X)
                                                     (NEQ (CDR X)
                                                          VAL])

(HASDEF
  [LAMBDA (NAME TYPE SOURCE SPELLFLG)                    (* ; "Edited 31-Aug-87 18:02 by drc:")

    (* ;; "is NAME the name of something of type TYPE?  NIL SOURCE means 0, not ?")

    (DECLARE (SPECVARS TYPE))
    (COND
       [[OR (LISTP TYPE)
            (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG")
        (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
                                            (RETURN $$VAL]
       (T
        (PROG [(NODEF (fetch NULLDEF of TYPE))
               (OPTS '(NODWIM NOCOPY NOERROR HASDEF]
              (COND
                 ((NULL SOURCE)
                  (SETQQ SOURCE CURRENT)))
              (RETURN
               (SELECTQ SOURCE
                   ((CURRENT 0) 
                        [COND
                           ([OR
                             (MEMBER NAME (fetch CHANGED of TYPE))
                             (LET ((TM (fetch HASDEF of TYPE)))
                                  (COND
                                     (TM (APPLY* TM NAME TYPE SOURCE))
                                     [(NOT (LITATOM NAME))
                                      (SELECTQ TYPE
                                          (PROPS (AND (LISTP NAME)
                                                      (GETPROP (CAR NAME)
                                                             (CADR NAME))))
                                          ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS 
                                                  FIELDS USERMACROS FILEVARS FILEPKGCOMS) 
                                               NIL)
                                          (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                                     (T 
                                        (* ;; "symbol definitions")

                                        (SELECTQ TYPE
                                            (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS")
                                                                        "INTERLISP")))
                                                        (AND SYMBOL (BOUNDP SYMBOL))))
                                            (TEMPLATES (GETTEMPLATE NAME))
                                            (MACROS (GETLIS NAME MACROPROPS))
                                            (LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
                                                             (FASSOC NAME LISPXHISTORYMACROS)))
                                            (VARS (AND (NOT (CL:KEYWORDP NAME))
                                                       (NEQ (GETTOPVAL NAME)
                                                            'NOBIND)))
                                            (RECORDS (RECLOOK NAME))
                                            (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD]
                                                            (RETURN (AND TEM (EQ (CAR TEM)
                                                                                 'FORWORD)
                                                                         (GETPROP (CDR TEM)
                                                                                'I.S.OPR])
                                            (FNS (AND (OR (AND (GETD NAME)
                                                               (EXPRP (GETD NAME)))
                                                          (GET NAME 'EXPR))
                                                      (NOT (HASDEF NAME 'FUNCTIONS SOURCE))))
                                            (FIELDS (RECORDFIELD? NAME))
                                            (USERMACROS (FASSOC NAME USERMACROS))
                                            (FILEVARS)
                                            ((PROPS ALISTS DEFS EXPRESSIONS) 
                                                 NIL)
                                            (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
                                                             (FMEMB NAME FILEPKGTYPES)))
                                            (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                            (OR NAME T))
                           (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME)
                                         (FIXSPELL NAME NIL
                                                (SELECTQ TYPE
                                                    (FILES FILELST)
                                                    (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES))
                                                    (FIELDS (for X in USERRECLST
                                                               join (APPEND (RECORDFIELDNAMES
                                                                                 X))))
                                                    (RECORDS (for X in USERRECLST
                                                                when (LITATOM (CADR X))
                                                                collect (CADR X)))
                                                    (LISPXMACROS LISPXCOMS)
                                                    (I.S.OPRS I.S.OPRLST)
                                                    (USERMACROS (MAPCAR USERMACROS
                                                                       (FUNCTION CAR)))
                                                    USERWORDS)
                                                NIL
                                                (LISTP SPELLFLG)
                                                [FUNCTION (LAMBDA (X)
                                                            (HASDEF X TYPE 'CURRENT]
                                                NIL T))])
                   (? (OR (HASDEF NAME TYPE 'CURRENT)
                          (AND (LITATOM NAME)
                               (HASDEF NAME TYPE 'SAVED SPELLFLG))
                          (WHEREIS NAME TYPE T)))
                   ((SAVED T) 
                        (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS)))
                   (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])

(GETFILEDEF
  [LAMBDA (FILENAME)                                     (* lmm " 4-Jul-85 13:25")

    (* ;; 
  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST")

    (COND
       ((FMEMB FILENAME FILELST)
        FILENAME)
       (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T)
             do (COND
                       ((EQ (FILENAMEFIELD FILE 'NAME)
                            FILENAME)
                        (RETURN FILE])

(SAVEDEF
  [LAMBDA (NAME TYPE DEFINITION)                         (* JonL "24-Jul-84 20:11")
    (COND
       [(AND (LISTP NAME)
             (NULL TYPE))
        (MAPCAR NAME (FUNCTION (LAMBDA (I)
                                 (SAVEDEF I 'FNS]
       (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME)))
                        (/PUT NAME [SETQ TYPE (COND
                                                 ((SUBRP DEFINITION)
                                                  'SUBR)
                                                 ((EXPRP DEFINITION)
                                                  'EXPR)
                                                 ((CCODEP DEFINITION)
                                                  'CODE)
                                                 (T 'LIST]
                              DEFINITION)))
              (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME)))
                              'NOBIND)
                         (EQ DEFINITION (GETTOPVAL NAME))
                         (/PUT NAME (SETQ TYPE 'VALUE)
                               DEFINITION)))
              (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT
                                                          '(NOCOPY NOERROR NODWIM]
                   (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS))
                                                  (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME))
                                                                             SAVEDDEFS]
          TYPE])

(UNSAVEDEF
  [LAMBDA (NAME TYPE DEF)                                (* lmm " 6-Jun-86 17:24")
    (SELECTQ TYPE
        ((NIL EXPR CODE SUBR LIST) 
             (COND
                [(LISTP NAME)                                (* ; "for compatibility")
                 (MAPCAR NAME (FUNCTION (LAMBDA (X)
                                          (UNSAVED1 X TYPE]
                (T (UNSAVED1 NAME TYPE))))
        (PROG NIL
              [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
                                       'SAVED 0))
                  (RETURN (CONS TYPE '(not found]
              (COND
                 ((NEQ DFNFLG T)
                  (SAVEDEF NAME TYPE)
                  (LET ((DFNFLG T))
                       (PUTDEF NAME TYPE DEF)))
                 (T (PUTDEF NAME TYPE DEF)))
              (RETURN TYPE])

(COMPAREDEFS
  [LAMBDA (NAME TYPE SOURCES)                            (* lmm " 4-Jul-85 14:37")
    (COND
       ((AND (LISTP TYPE)
             (GETFILEPKGTYPE SOURCES NIL T))
        (swap TYPE SOURCES)))
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T]
          [COND
             ((NULL SOURCES)
              (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE))
                       (SOME SRCS (FUNCTION (LAMBDA (FILE)
                                              (MEMBER NAME (CDR (ASSOC TYPE
                                                                       (fetch TOBEDUMPED
                                                                          of (fetch FILEPROP
                                                                                    of FILE]
                   (push SRCS 'CURRENT]
          (SETQ SRCS (for SRC in SRCS
                        when (COND
                                    ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
                                          (fetch NULLDEF of TYPE))
                                     (OR [SOME DEFS (FUNCTION (LAMBDA (DP)
                                                                (COMPARELST DEF (CDR DP]
                                         (push DEFS (CONS SRC DEF)))
                                     T)
                                    (T (PRINTOUT T "No " SRC " definition found for " NAME T)
                                       NIL)) collect SRC))
          (RETURN (COND
                     ((NULL SRCS)
                      '(no definitions found))
                     ((NULL (CDR SRCS))
                      '(only one definition found))
                     ((CDR DEFS)
                      [for S1 on (DREVERSE DEFS)
                         do (for S2 on (CDR S1) do (PRIN2 NAME T T)
                                                                  (AND (CAAR S1)
                                                                       (PRIN1 " from " T)
                                                                       (PRIN2 (CAAR S1)
                                                                              T T))
                                                                  (PRIN1 " and " T)
                                                                  (PRIN2 NAME T T)
                                                                  (COND
                                                                     ((CAAR S2)
                                                                      (PRIN1 " from " T)
                                                                      (PRIN2 (CAAR S2)
                                                                             T T)))
                                                                  (PRIN1 " differ:" T)
                                                                  (TERPRI T)
                                                                  (COMPARELISTS (CDAR S1)
                                                                         (CDAR S2]
                      'DIFFERENT)
                     (T 'SAME])

(COMPARE
  [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2)             (* lmm " 5-SEP-78 13:37")
    (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY]
           (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY]
          (COND
             ((COMPARELST DEF1 DEF2)
              (RETURN)))
          (PRIN2 NAME1 T T)
          (COND
             (SOURCE1 (PRIN1 " from " T)
                    (PRIN2 SOURCE1 T T)))
          (PRIN1 " and " T)
          (PRIN2 NAME2 T T)
          (COND
             (SOURCE2 (PRIN1 " from " T)
                    (PRIN2 SOURCE2 T T)))
          (PRIN1 " differ:" T)
          (TERPRI T)
          (COMPARELISTS DEF1 DEF2)
          (RETURN T])

(TYPESOF
  [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER)
                                                          (* ; "Edited  2-Aug-88 02:08 by masinter")

    (* ;; "return list of all known types which NAME names")

    (LET
     (FOUND SHADOWED)
     (if (FMEMB SOURCE '(? NIL))
         then (CL:FLET [(RSHADOW NIL (for X in FOUND
                                            do (for Y in (CDR (FASSOC X SHADOW-TYPES))
                                                      do (if (FMEMB Y FOUND)
                                                                 then 
                                                             (* ; "shadower found before shadowed")
                                                                       (SETQ FOUND (REMOVE Y FOUND]
                         (LET (NOTFOUND NEWTYPES)
                              (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                                 when [AND (LITATOM TYPE)
                                               (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                               (OR (NULL FILTER)
                                                   (CL:FUNCALL FILTER TYPE))
                                               (NOT (find X in FOUND
                                                       suchthat (FMEMB TYPE
                                                                           (CDR (FASSOC X 
                                                                                       SHADOW-TYPES]
                                 do (if [OR (HASDEF NAME TYPE 'CURRENT)
                                                    (AND (LITATOM NAME)
                                                         (HASDEF NAME TYPE 'SAVED]
                                            then (push FOUND TYPE)
                                          else (push NOTFOUND TYPE)))
                              (RSHADOW)
                              [for FILE in FILELST while NOTFOUND
                                 when [NEQ T (fetch LOADTYPE of (GETPROP FILE
                                                                                   'FILE]
                                 do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND
                                                                      (FILECOMS FILE)
                                                                      'TYPESOF))
                                            then [bind X for TYPE in NEWTYPES
                                                        when (FMEMB TYPE NOTFOUND)
                                                        do (push FOUND TYPE)
                                                              (if (SETQ X (FASSOC TYPE 
                                                                                     SHADOW-TYPES))
                                                                  then (SETQ NOTFOUND
                                                                            (LDIFFERENCE NOTFOUND X))
                                                                else (SETQ NOTFOUND
                                                                          (REMOVE TYPE NOTFOUND]
                                                  (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES]
                              (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF))
                                  then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND))
                                        (SETQ FOUND (UNION NEWTYPES FOUND)))
                              (RSHADOW)
                              FOUND))
       else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                   when (AND (LITATOM TYPE)
                                 (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                 (OR (NULL FILTER)
                                     (CL:FUNCALL FILTER TYPE))
                                 (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE)))
     FOUND])
)

(RPAQ? WHEREIS.HASH )



(* ; "Must come after PUTDEF")

(DEFINEQ

(FIXEDITDATE
  [LAMBDA (EXPR)                                         (* ; "Edited 17-Jul-89 11:13 by jtm:")
                                                             (* NOBIND "18-JUL-78 21:11")
                                                             (* Inserts or replaces previous edit 
                                                           date)
    (AND INITIALS (LISTP EXPR)
         (LISTP (CDR EXPR))
         (PROG (E)
               (COND
                  ((FMEMB (CAR EXPR)
                          LAMBDASPLST)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR)))
                  [(FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-ARGLIST-DEFINERS)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR))
                   (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
                      finally (SETQ E (CDR E]
                  ((FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-NAME-DEFINERS)

                   (* ;; "insert the edit date after the name")

                   (SETQ E (CDDR EXPR)))
                  (T (RETURN)))
           RETRY
               [COND
                  ((NLISTP E)
                   (RETURN))
                  ((LISTP (CAR E))
                   (SELECTQ (CAAR E)
                       ((CLISP%: DECLARE) 
                            (SETQ E (CDR E))
                            (GO RETRY))
                       (BREAK1 (COND
                                  ((EQ (CAR (CADAR E))
                                       'PROGN)
                                   (SETQ E (CDR (CADAR E)))
                                   (GO RETRY))))
                       (ADV-PROG                             (* No easy way to mark cleanly the 
                                                           date of an advised function)
                                 (RETURN))
                       (COND
                          ((AND (EQ (CAAR E)
                                    COMMENTFLG)
                                (EQ (CADAR E)
                                    'DECLARATIONS%:))
                           (SETQ E (CDR E))
                           (GO RETRY]
               (COND
                  ([for TAIL on E while (AND (LISTP (CAR TAIL))
                                                         (EQ (CAAR TAIL)
                                                             COMMENTFLG))
                      do (COND
                                ((AND (LISTP (CDR TAIL))
                                      (EDITDATE? (CAR TAIL)))
                                 (/RPLACA TAIL (EDITDATE (CAR TAIL)
                                                      INITIALS))
                                 (RETURN T]                  (* scans the comments for a 
                                                           timestamp for this user.)
                   NIL)
                  (T                                         (* attach the new timestamp at the 
                                                           beginning of the comments.)
                     (/ATTACH (EDITDATE NIL INITIALS)
                            E)))
               (RETURN EXPR])

(EDITDATE?
  [LAMBDA (COMMENT)                                      (* ; "Edited 11-Jun-92 16:44 by cat")
                                                             (* ; "Edited 13-Jul-89 09:30 by jtm:")
                                                             (* lmm "21-Mar-85 08:45")

         (* Tests to see if a given common is in fact an edit date --
       this has to be general enough to recognize the most comment comment forms while 
       specific enough to not recognize things that are not edit dates)

    (DECLARE (LOCALVARS . T))                            (* jtm%: changed test so that it 
                                                           creates one timestamp per user.)
    (COND
       [(LISTP COMMENT)
        (COND
           ((EQ (CAR COMMENT)
                COMMENTFLG)
            [COND
               (NIL (NULL NORMALCOMMENTSFLG)
                    (SETQ COMMENT (GETCOMMENT COMMENT]
            (COND
               ([OR (NOT (LISTP (CDR COMMENT)))
                    (NOT (LISTP (CDDR COMMENT]
                NIL)
               [(EQ (CADR COMMENT)
                    ';)                                      (* ; "CL style comment")
                (STRPOS INITIALS (CADDR COMMENT)
                       (IMINUS (NCHARS INITIALS]
               (T                                            (* ; "IL style comment")
                  (EQ (CADR COMMENT)
                      INITIALS]
       ((STRINGP COMMENT])
)



(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")


(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))

(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
)



(* ;; 
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
)

(DEFINEQ

(FILEPKGCOM
  [LAMBDA N                                              (* JonL "10-Jul-84 19:38")
    (PROG (TEM (COM (ARG N 1)))
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in '(MACRO CONTENTS DELETE ADD)
                             when (SETQ TEM (FILEPKGCOM COM FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                               (LIST 'COM T))
                          (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                               (LIST 'COM TEM]
                     ((EQ N 2)
                      (SELECTQ (ARG N 2)
                          (ADD (fetch ADD of COM))
                          (DELETE (fetch DELETE of COM))
                          (MACRO (fetch MACRO of COM))
                          ((CONTENTS CONTAIN) 
                               [OR (fetch (FILEPKGCOM CONTENTS) of COM)
                                   (COND
                                      ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM))
                                       (COND
                                          ((EQ COM 'NILL)
                                           COM)
                                          [(EQ (CAR COM)
                                               'LAMBDA)
                                           (CONS (CAR COM)
                                                 (CONS [CONS (CAADR COM)
                                                             (CONS (OR (CADDR (CADR COM))
                                                                       'NAME)
                                                                   (CONS (CADR (CADR COM))
                                                                         (CDDDR (CADR COM]
                                                       (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM]
                                          (T (LIST 'LAMBDA '(COM TYPE NAME)
                                                   (CONS COM '(COM TYPE NAME])
                          (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                        T)
                                   (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST])
                          (ERROR (ARG N 2)
                                 "not file package command property")))
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'COM)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                (/SETTOPVAL 'FILEPKGCOMSPLST
                                                       (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST])
                                         (COND
                                            ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGCOMSPLST
                                                      (CONS (CONS COM TEM)
                                                            (GETTOPVAL 'FILEPKGCOMSPLST]
                                    (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                    (/SETTOPVAL 'FILEPKGCOMSPLST
                                                           (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                       (SELECTQ (ARG N I)
                                           (ADD (/replace (FILEPKGCOM ADD) of COM
                                                   with TEM))
                                           (DELETE (/replace (FILEPKGCOM DELETE) of
                                                                                         COM
                                                      with TEM))
                                           (MACRO (/replace (FILEPKGCOM MACRO) of COM
                                                     with TEM))
                                           ((CONTENTS CONTAIN) 
                                                (/replace (FILEPKGCOM CONTENTS) of COM
                                                   with TEM))
                                           (ERROR (ARG N I)
                                                  "not file package command property"]
                        (MARKASCHANGED COM 'FILEPKGCOMS])

(FILEPKGTYPE
  [LAMBDA N                                              (* lmm " 5-Jul-85 09:07")
    (PROG ((TYPE (ARG N 1))
           TEM)
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in (UNION '(DESCRIPTION)
                                                       FILEPKGTYPEPROPS)
                             when (SETQ TEM (FILEPKGTYPE TYPE FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                               (LIST 'TYPE T))
                          (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]
                               (LIST 'TYPE TEM]
                     [(EQ N 2)
                      (if (FMEMB (ARG N 2)
                                     FILEPKGTYPEPROPS)
                          then (GETPROP TYPE (ARG N 2))
                        else (SELECTQ (ARG N 2)
                                     (DESCRIPTION (fetch DESCRIPTION of TYPE))
                                     (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                                                    T)
                                               (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES])
                                     (ERROR (ARG N 2)
                                            "not file package type property"]
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'TYPE)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T (OR (FMEMB TYPE FILEPKGTYPES)
                                                (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES))))
                                         (COND
                                            ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES))
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM)
                                                                               FILEPKGTYPES]
                                    (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES)
                                                    (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES
                                                                                    ]
                                       (if (FMEMB (ARG N I)
                                                      FILEPKGTYPEPROPS)
                                           then (if TEM
                                                        then (/PUTPROP TYPE (ARG N I)
                                                                        TEM)
                                                      else (/REMPROP TYPE (ARG N I)))
                                         else (SELECTQ (ARG N I)
                                                      (DESCRIPTION (/replace DESCRIPTION
                                                                      of TYPE with TEM))
                                                      (ERROR (ARG N I)
                                                             "not file package command/type property"
                                                             ]
                        (MARKASCHANGED TYPE 'FILEPKGCOMS])
)

(PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS)))

(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)

(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE)
                                                                       (* Revert to NILL when no 
                                                                          longer coercing 
                                                                          PRETTYDEFMACROS to 
                                                                          FILEPKGCOMS)
                                                                       (AND (EQ TYPE 'FILEPKGCOMS)
                                                                            (INFILECOMTAIL COM]
                                                  (TYPE DESCRIPTION "file package commands/types" 
                                                        GETDEF T PUTDEF FILEPKGCOMS.PUTDEF)))
(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X]
                                             (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF 
                                                   WHENCHANGED (ALISTS.WHENCHANGED))))
(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X])
(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS)))
(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED (
                                                                              EXPRESSIONS.WHENCHANGED
                                                                                               )
                                                        EDITDEF NILL)))
(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL)))
(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)
                                                   (TYPE TYPE FILEPKGCOMS)))
(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X]
                                                 CONTENTS
                                                 (LAMBDA (COM NAME TYPE)
                                                        (AND (EQ TYPE 'FILES)
                                                             (SUBSET (INFILECOMTAIL COM)
                                                                    (FUNCTION LITATOM]
                                            (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED)
                                                  EDITDEF EDITDEF.FILES)))
(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X)))
                                               (TYPE NULLDEF NOBIND EDITDEF NILL)))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (FN)
                                                                         (AND (GETPROP FN
                                                                                     'FUNCTIONS)
                                                                              (CL:WARN 
                                                                      "~A has a FUNCTIONS definition"
                                                                                     FN]
                                                  (ORIGINAL (FNS . X)))
                                               CONTENTS NILL)
                                          (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF
                                                T)))
(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X)))
                                                       CONTENTS
                                                       (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                              (AND (NULL ONFILETYPE)
                                                                   (EQ TYPE 'RECORDS)
                                                                   (INFILECOMTAIL COM])
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS)))
(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X)))
                                                       CONTENTS NILL)
                                                  (TYPE DESCRIPTION "LISPX commands")))
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM
                                              MACRO
                                              [X
                                               (DECLARE%:
                                                EVAL@COMPILE
                                                (P
                                                 *
                                                 (MAPCAR
                                                  'X
                                                  (FUNCTION
                                                   (LAMBDA (Y)
                                                          (LET [[FNDEF (GETDEF Y 'FUNCTIONS
                                                                              'CURRENT
                                                                              '(NOCOPY NOERROR]
                                                                (MACDEF (GETDEF Y 'MACROS
                                                                               'CURRENT
                                                                               '(NOCOPY NOERROR]
                                                               (COND
                                                                ((AND FNDEF (EQ (CAR FNDEF)
                                                                                'DEFMACRO))
                                                                 (CL:WARN 
                           "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S."
                                                                        FNDEF)
                                                                 (LIST 'PROGN FNDEF MACDEF))
                                                                (T (OR MACDEF (CL:CERROR 
                                                          "Go ahead and finish writing out the file."
                                                                                     
                                                                       "No MACROS definition for ~A."
                                                                                     Y)
                                                                       (GETDEF Y 'MACROS 'CURRENT]
                                              CONTENTS NILL)
                                             (TYPE DESCRIPTION "Interlisp macros" GETDEF 
                                                   MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY))))
(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)))
(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X]
                                            (TYPE DESCRIPTION "property lists" WHENCHANGED (
                                                                                    PROPS.WHENCHANGED
                                                                                            ))))
(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM
                                               MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (RECORD)
                                                                         (AND (GETPROP RECORD
                                                                                     'STRUCTURES)
                                                                              (CL:WARN 
                                                                     "~A has a STRUCTURES definition"
                                                                                     RECORD]
                                                  (E (RECORDECLARATIONS . X))
                                                  (INITRECORDS . X))
                                               CONTENTS
                                               (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                      (AND (EQ TYPE 'FIELDS)
                                                           (NULL ONFILETYPE)
                                                           (MAPCONC (INFILECOMTAIL COM)
                                                                  (FUNCTION (LAMBDA
                                                                             (X)
                                                                             (APPEND (
                                                                                     RECORDFIELDNAMES
                                                                                      X]
                                              (TYPE DESCRIPTION "records" DELDEF
                                                    (LAMBDA (X)
                                                           (/SETTOPVAL 'USERRECLST
                                                                  (REMOVE (RECLOOK X)
                                                                         USERRECLST])
(PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X)))
                                                      CONTENTS
                                                      (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                             (AND (NULL ONFILETYPE)
                                                                  (EQ TYPE 'RECORDS)
                                                                  (INFILECOMTAIL COM])
(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X)))
                                                      CONTENTS NILL)
                                                 (TYPE DESCRIPTION "edit macros")))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                                (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                          (VAR)
                                                                          (AND (GETPROP VAR
                                                                                      'VARIABLES)
                                                                               (CL:WARN 
                                                                 "~A also has a VARIABLES definition"
                                                                                      VAR]
                                                   (ORIGINAL (VARS . X)))
                                                CONTENTS NILL)
                                           (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF 
                                                 VARS.PUTDEF)))
(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL)))
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X)
                                                                     (P (CONSTANTS . X])

(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
                           (VARIABLES VARS CONSTANTS))

(RPAQ? SAVEDDEFS )



(* ; "EDITCALLERS")

(DEFINEQ

(FINDCALLERS
  [LAMBDA (ATOMS FILES)                                  (* lmm "30-SEP-78 01:36")
    (PROG ((X (EDITCALLERS ATOMS FILES T)))
          (RETURN (NCONC (DREVERSE (CDR X))
                         (AND (CAR X)
                              (LIST (CONS (COND
                                             ((CDR X)
                                              '"plus other places on")
                                             (T 'on))
                                          (CAR X])

(EDITCALLERS
  [LAMBDA (ATOMS FILES COMS)                            (* ; "Edited 18-Apr-2018 10:41 by rmk:")
                                                             (* bvm%: " 3-Nov-86 17:30")
    (LET
     (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN)
     [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS]
     [for FILE in (COND
                             ((NULL FILES)
                              FILELST)
                             ((EQ FILES T)
                              (UNION SYSFILES FILELST))
                             ((LISTP FILES)
                              FILES)
                             (T (LIST FILES)))
        do
        (RESETLST
            [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I)
                  (OR (SETQ FULL (FINDFILE FILE))
                      (RETURN (LISPXPRINT (CONS FILE '(not found))
                                     T T)))
                  [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT]
                  (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM)))
                  (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP)
                         (OR (GET-ENVIRONMENT-AND-FILEMAP FULL)
                             (\PARSE-FILE-HEADER FILESTREAM)))

             (* ;; "Get reader environment of file.  The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists.  Otherwise, read the top of the file")

                  (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV)))
                  (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL))
                  [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS)))
                      (push FFILEPOSPATTERNS
                             (CONS RDTBL (SETQ PATTERNS
                                          (for ATOM in ATOMS
                                             collect (CONCAT
                                                          (COND
                                                             ((EQ (CHCON1 ATOM)
                                                                  (CHARCODE ESCAPE))
                                                              (SETQ ATOM (SUBSTRING ATOM 2 -1))
                                                              "")
                                                             (T " "))
                                                          [COND
                                                             ((SETQ I (STRPOS ' ATOM))
                                                              (SUBSTRING ATOM 1 (SUB1 I)))
                                                             ((STRINGP ATOM))
                                                             (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE
                                                                                  ATOM)))
                                                             (* ; 
                                                           "Keep MKSTRING from putting a prefix on")
                                                                     (MKSTRING ATOM T RDTBL]
                                                          (COND
                                                             (I "")
                                                             (T " "]
                  (for PATTERN in PATTERNS
                     do
                     (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0)))
                     (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA))
                        do
                        (COND
                           ((NULL PRINTFLG)                  (* ; 
                                   "cause the printing of the filename to be saved on history list")
                            (SETQ PRINTFLG T)
                            (LISPXPRIN2 FULL T T T)

                            (* ;; "print with NODOFLG=T means just to record the printing;  the idea is that only those files in which something is found will be remembered on the history list")

                            (LISPXPRIN1 ": " T NIL T)))
                        [OR
                         [AND (NEQ MAP T)
                              (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0)
                                                                    (SETQ MAP (OR (GETFILEMAP 
                                                                                         FILESTREAM)
                                                                                  (LOADFILEMAP 
                                                                                         FILESTREAM]
                                                         (PROGN 
                                                             (* ; "file has no filemap")
                                                                (SETQ MAP (SETQ NOMAPFLG T))
                                                                (LISPXPRIN1 " no filemap!" T)
                                                                NIL)))
                                 thereis (AND (ILESSP (CAR X)
                                                         I)
                                                  (IGREATERP (CADR X)
                                                         I)
                                                  (for Z in (CDDR X)
                                                     thereis (COND
                                                                    ((AND (ILESSP (CADR Z)
                                                                                 I)
                                                                          (IGREATERP (CDDR Z)
                                                                                 I))
                                                                     [COND
                                                                        ((NOT (FMEMB (CAR Z)
                                                                                     FNS))
                                                                         (SETQ FNS
                                                                          (CONS (LISPXPRIN2
                                                                                 (CAR Z)
                                                                                 T T)
                                                                                FNS]
                                                                     (SETQ I (CDDR Z))
                                                                     T]
                         (PROGN (LISPXPRIN2 I T T)
                                (OR (FMEMB FILE OTHERSFILES)
                                    (SETQ OTHERSFILES (CONS FILE OTHERSFILES]
                        (LISPXSPACES 1 T)))
                  (COND
                     (PRINTFLG (LISPXTERPRI T))
                     (T (TERPRI T)))
                  (COND
                     ((NEQ COMS T)
                      (COND
                         ((OR FNS OTHERSFILES)
                          (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS))
                                 FULL EDITPATTERN COMS (NULL OTHERSFILES))
                          (SETQ OTHERSFILES)
                          (SETQ FNS])]
     (COND
        ((EQ COMS T)
         (CONS OTHERSFILES FNS])

(EDITFROMFILE
  [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES)     (* rmk%: "14-Mar-85 21:51")
    (RESETVARS [(EDITLOADFNSFLG (COND
                                   ((EQ EDITLOADFNSFLG T)
                                    '(T . NO))
                                   (T EDITLOADFNSFLG]
               (PROG NIL
                     [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN]
                     (AND
                      (SETQ FILES (for FILE inside (OR FILES FILELST)
                                     when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE)
                                                                             FILELST))
                                                  (COND
                                                     ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" 
                                                                                        FILE)
                                                                    NIL T))
                                                      (LOADFROM FILE FNS 'ALLPROP)
                                                      T))) collect FILE))
                      (for TYPE in [COND
                                              ((LISTP ONLYTYPES))
                                              (ONLYTYPES '(FNS))
                                              (T 

                                 (* ;; "Move FNS to the front.  This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.")

                                                 (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES]
                         when (AND (LITATOM TYPE)
                                       (NEQ (fetch EDITDEF of TYPE)
                                            'NILL))
                         do
                         (PROG (SEEN)
                               (for FILE inside FILES
                                  do
                                  (for NAME in [COND
                                                          ((AND (EQ TYPE 'FNS)
                                                                (NEQ FNS T))
                                                             (* ; 
                                                    "for this type, we are given the list of items")
                                                           (PROG1 FNS (SETQ FNS NIL)))
                                                          (T (* ; 
                             "only want the values of `TYPE' which are not part of some other type")
                                                             (FILECOMSLST FILE TYPE 'EDIT]
                                     unless (MEMBER NAME SEEN)
                                     do
                                     (ERSETQ
                                      (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT
                                                             '(NOCOPY NOERROR))
                                                      (GETDEF NAME TYPE 'SAVED
                                                             '(NOCOPY NOERROR]

                                 (* ;; "If definition has been loaded, it may have been editted.  Work on that explicitly instead of bringing in a file definition to smash the users previous changes.  Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS.  --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file.  But ...  rmk")

                                            (COND
                                               ((OR (AND (EQ TYPE 'FNS)
                                                         (NEQ FNS T))
                                                    (AND (LISTP DEF)
                                                         (LOOKIN DEF EDITPATTERN)))
                                                (COND
                                                   ((NULL SEEN)
                                                    (LISPXPRIN1 "editing the " T)
                                                    (LISPXPRIN1 (OR (fetch DESCRIPTION
                                                                       of TYPE)
                                                                    TYPE)
                                                           T)
                                                    (LISPXSPACES 1 T)))
                                                (SETQ SEEN (CONS NAME SEEN))
                                                (LISPXPRIN2 NAME T T)
                                                (LISPXPRIN1 ":
" T)
                                                (COND
                                                   ((NOT
                                                     (ERSETQ (EDITDEF
                                                              NAME TYPE
                                                              (OR (AND DEF (CONS '= DEF))
                                                                  FILE)
                                                              EDITCOMS)))
                                                    (LISPXPRIN1 "failed" T)))
                                                (LISPXTERPRI T])

(FINDATS
  [LAMBDA (X L)                                          (* lmm "11-FEB-78 16:03")
    (COND
       ((NLISTP X)
        (FMEMB X L))
       (T (OR (FINDATS (CAR X)
                     L)
              (FINDATS (CDR X)
                     L])

(LOOKIN
  [LAMBDA (X PAT)                                        (* lmm "11-MAR-78 14:20")
    (COND
       ([AND (EQ (CAR PAT)
                 '*ANY*)
             (EVERY (CDR PAT)
                    (FUNCTION (LAMBDA (X)
                                (AND (LITATOM X)
                                     (NOT (STRPOS ' X]
        (FINDATS X (CDR PAT)))
       (T (EDITFINDP X PAT T])
)
(DEFINEQ

(SEPRCASE
  [LAMBDA (CLFLG RDTBL)                                  (* bvm%: "24-Oct-86 18:16")

    (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent.  Based on FILERDTBL, but others are close with respect to breaks and seprs")

    (OR RDTBL (SETQ RDTBL FILERDTBL))
    (OR [ARRAYP (CDR (ASSOC RDTBL (COND
                                     (CLFLG CLISPCASEARRAYS)
                                     (T SEPRCASEARRAYS]
        (LET ((CA (CASEARRAY)))
             [if (READTABLEPROP RDTBL 'CASEINSENSITIVE)
                 then                                    (* ; "map upper into lower case")
                       (for I from (CHARCODE A) to (CHARCODE Z)
                          do (SETCASEARRAY CA I (+ I (- (CHARCODE a)
                                                            (CHARCODE A]
             (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS
                                                    collect (CHCON1 Y)))
                                      (GETSEPR RDTBL)
                                      (GETBRK RDTBL)) do (SETCASEARRAY CA X 0))
             (if *PACKAGE*
                 then                                    (* ; 
                               "symbols qualified with package prefix will otherwise be unfindable")
                       (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR)
                              0))
             (SETQ CA (CONS RDTBL CA))
             (COND
                (CLFLG (push CLISPCASEARRAYS CA))
                (T (push SEPRCASEARRAYS CA)))
             (CDR CA])
)

(RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL))

(RPAQ? SEPRCASEARRAYS )

(RPAQ? CLISPCASEARRAYS )

(MOVD? 'INFILEP 'FINDFILE)

                                                             (* ; "or else from SPELLFILE")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
       (NOLINKFNS LOADFROM))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)
)



(* ; "EXPORT")

(DEFINEQ

(IMPORTFILE
  [LAMBDA (FILE RETURNFLG)                               (* lmm " 6-Jun-86 17:43")
    (RESETLST
        [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT]
        (RESETSAVE (INPUT FILE))                             (* ; 
                "Reset INPUT in case some form on the file's action is to read the next expression")
        (NCONC [COND
                  ((EQ RETURNFLG T)                          (* ; 
                                           "Just creating EXPORTS.ALL, don't side-effect the world")
                   (IMPORTFILESCAN FILE RETURNFLG))
                  (T (LET (FILEPKGFLG DFNFLG)
                          (IMPORTFILESCAN FILE RETURNFLG]
               (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE))
                                     ''IMPORTDATE
                                     (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE]
                      RETURNFLG)))])

(IMPORTEVAL
  [LAMBDA (FORM RETURNFLG)                               (* ; "Edited  2-May-87 18:57 by Pavel")

    (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")

    (AND (LISTP FORM)
         (SELECTQ (CAR FORM)
             (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (/DECLAREDATATYPE                               (* ; 
                    "Ignore datatype initializations -- we only need the record declaration itself")
                  NIL)
             (PROGN                                          (* ; "default: eval and/or return it")
                    (AND (NEQ RETURNFLG T)
                         (EVAL FORM))
                    (AND RETURNFLG (LIST FORM])

(IMPORTFILESCAN
  [LAMBDA (FILE RETURNFLG)                               (* bvm%: "24-Oct-86 19:31")
    (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
        (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
           join (until (EQUAL (SETQ DEF (READ FILE))
                                      ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])

(CHECKIMPORTS
  [LAMBDA (FILES NOASKFLG)                               (* rmk%: "19-FEB-83 16:31")
                                                             (* ; 
                                           "Loads exported definitions from new versions of FILES.")
    (COND
       ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE
                            when [AND (SETQ FULLFILENAME (FINDFILE FILE T))
                                          (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE)
                                                                     'IMPORTDATE]
                                              (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 
                                                                     'ICREATIONDATE]
                            collect (LIST FILE FULLFILENAME)))
             (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from "
                                                       (MAPCAR FILES (FUNCTION CAR)))
                                          '((Y "es
")
                                            (N "o
"))
                                          T)
                              (N NIL)
                              T)))
        (for FILE in FILES do (IMPORTFILE (CADR FILE])

(GATHEREXPORTS
  [LAMBDA (FROMFILES TOFILE FLG)                         (* bvm%: "14-Oct-86 23:12")
                                                             (* ; 
                                        "Copies all exported definitions from FROMFILES to TOFILE.")
    (RESETLST
        [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE)
                             (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT]
        (RESETSAVE (OUTPUT TOFILE))
        (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*))
             (SETQ ENV (if ENV
                           then (\DO-DEFINE-FILE-INFO NIL ENV)
                         else *OLD-INTERLISP-READ-ENVIRONMENT*))
             (WITH-READER-ENVIRONMENT ENV
                 (PRINT-READER-ENVIRONMENT ENV)
                 (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T)
                        " ON "
                        (DATE)
                        "%"  T)" T "(LISPXTERPRI T)" T)
                 (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T))
                                                              (FUNCTION PRINT))
                                                       (TERPRI))
                 (PRINT 'STOP)
                 (TERPRI)
                 (FULLNAME TOFILE))))])

(\DUMPEXPORTS
  [NLAMBDA COMS                                          (* bvm%: "24-Oct-86 19:42")

(* ;;; "Dumps an EXPORT form.  IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.")

    (PRIN1 "(")
    (PRIN2 '*)
    (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2))               (* ; 
                                   "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE")
    (for TAIL on COMS do (PRETTYCOM (CAR TAIL)))
    (TERPRI)
    (PRINT ENDEXPORTDEFFORM)
    (TERPRI])
)
(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X])

(RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")

(RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)
)



(* ; "for GAINSPACE")

(DEFINEQ

(CLEARFILEPKG
  [LAMBDA (FLG)                                          (* bvm%: "29-Aug-86 13:02")
    (PROG NIL
          (COND
             ((SELECTQ FLG
                  ((E T) 
                       T)
                  (Y (TERPRI T)
                     (PRIN1 "you can delete just the filemaps -
" T)
                     (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? "
                                   '((Y "es - everything" RETURN T)
                                     (N "o - just the filemaps" RETURN NIL)
                                     (E "verything" RETURN T)
                                     (F "ilemaps only" RETURN NIL]
                            (TERPRI T)))
                  NIL)
              (UPDATEFILES)
              [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE)
                                                        (COND
                                                           ((fetch TOBEDUMPED
                                                               of (fetch FILEPROP
                                                                         of FILE))
                                                            (PRINT FILE T T)
                                                            (PRIN1 " has changes, not wiped." T)
                                                            (TERPRI T)
                                                            T)
                                                           (T (replace FILEPROP of FILE
                                                                 with NIL)
                                                              (replace FILECHANGES of FILE
                                                                 with NIL)
                                                              (SMASHFILECOMS FILE)
                                                              (NCONC1 SYSFILES FILE)
                                                              NIL]
              (SETQ LOADEDFILELST)))
          (SELECTQ FLG
              ((NIL T))
              (CLRHASH *FILEMAP-HASH*])
)

(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                    ((Y "es")
                                     (N "o")
                                     (E . "verything")
                                     (F "ilemaps only%
-"))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SMASHPROPSLST1)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST 
       DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS 
       LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG 
       MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS 
       FILEPKGTYPEPROPS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
       (SPECVARS COMSNAME))

(BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
       (NOLINKFNS . T)
       (SPECVARS COMSNAME)
       (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))

(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS 
       INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
       (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
       INFILECOMSPROP)

(BLOCK%: NIL MAKEFILE (LOCALVARS . T)
       (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))

(BLOCK%: ADDFILE ADDFILE ADDFILE0)

(BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))

(BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
       COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF 
       EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE
       FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES 
       MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED 
       MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
       SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF 
       UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS 
                          EDITLOADFNSFLG LOADOPTIONS)
       (LOCALVARS . T))

(BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))

(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
       GETDEFSAVED (RETFNS GETDEFCOM)
       (NOLINKFNS . T)
       (GLOBALVARS NOT-FOUNDTAG))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS 
                          MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS 
                          PRETTYDEFMACROS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1995 2018))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (22517 24222 (SEARCHPRETTYTYPELST 22527 . 23506) (PRETTYDEFMACROS 23508 . 23966) (
FILEPKGCOMPROPS 23968 . 24220)) (25024 58965 (CLEANUP 25034 . 26422) (COMPILEFILES 26424 . 26700) (
COMPILEFILES0 26702 . 27422) (CONTINUEDIT 27424 . 28844) (MAKEFILE 28846 . 40488) (FILECHANGES 40490
 . 42825) (FILEPKG.MERGECHANGES 42827 . 43650) (FILEPKG.CHANGEDFNS 43652 . 43964) (MAKEFILE1 43966 . 
48236) (COMPILE-FILE? 48238 . 49570) (MAKEFILES 49572 . 51265) (ADDFILE 51267 . 53788) (ADDFILE0 53790
 . 57926) (LISTFILES 57928 . 58963)) (59653 94893 (FILEPKGCHANGES 59663 . 61013) (GETFILEPKGTYPE 61015
 . 64088) (MARKASCHANGED 64090 . 65727) (FILECOMS 65729 . 66113) (WHEREIS 66115 . 67535) (
SMASHFILECOMS 67537 . 67772) (FILEFNSLST 67774 . 67936) (FILECOMSLST 67938 . 68422) (UPDATEFILES 68424
 . 73724) (INFILECOMS? 73726 . 75629) (INFILECOMTAIL 75631 . 76771) (INFILECOMS 76773 . 76934) (
INFILECOM 76936 . 87145) (INFILECOMSVALS 87147 . 87474) (INFILECOMSVAL 87476 . 88478) (INFILECOMSPROP 
88480 . 89309) (IFCPROPS 89311 . 90572) (IFCEXPRTYPE 90574 . 91085) (IFCPROPSCAN 91087 . 92140) (
IFCDECLARE 92142 . 93453) (INFILEPAIRS 93455 . 93787) (INFILECOMSMACRO 93789 . 94891)) (94928 125023 (
FILES? 94938 . 97131) (FILES?1 97133 . 97783) (FILES?PRINTLST 97785 . 98567) (ADDTOFILES? 98569 . 
108490) (ADDTOFILE 108492 . 109408) (WHATIS 109410 . 111386) (ADDTOCOMS 111388 . 113032) (ADDTOCOM 
113034 . 119581) (ADDTOCOM1 119583 . 120754) (ADDNEWCOM 120756 . 121806) (MAKENEWCOM 121808 . 123651) 
(DEFAULTMAKENEWCOM 123653 . 125021)) (125093 127910 (MERGEINSERT 125103 . 127446) (MERGEINSERT1 127448
 . 127908)) (129054 139966 (DELFROMFILES 129064 . 129914) (DELFROMCOMS 129916 . 131595) (DELFROMCOM 
131597 . 137465) (DELFROMCOM1 137467 . 138264) (REMOVEITEM 138266 . 139140) (MOVETOFILE 139142 . 
139964)) (140180 142549 (SAVEPUT 140190 . 142547)) (142674 150998 (UNMARKASCHANGED 142684 . 144392) (
PREEDITFN 144394 . 146905) (POSTEDITPROPS 146907 . 149408) (POSTEDITALISTS 149410 . 150996)) (151147 
171701 (ALISTS.GETDEF 151157 . 151536) (ALISTS.WHENCHANGED 151538 . 152182) (CLEARCLISPARRAY 152184 . 
153358) (EXPRESSIONS.WHENCHANGED 153360 . 153734) (MAKEALISTCOMS 153736 . 154809) (MAKEFILESCOMS 
154811 . 156248) (MAKELISPXMACROSCOMS 156250 . 158268) (MAKEPROPSCOMS 158270 . 158968) (
MAKEUSERMACROSCOMS 158970 . 160770) (PROPS.WHENCHANGED 160772 . 161393) (FILEGETDEF.LISPXMACROS 161395
 . 162837) (FILEGETDEF.ALISTS 162839 . 163458) (FILEGETDEF.RECORDS 163460 . 164391) (FILEGETDEF.PROPS 
164393 . 165185) (FILEGETDEF.MACROS 165187 . 166247) (FILEGETDEF.VARS 166249 . 166665) (FILEGETDEF.FNS
 166667 . 168031) (FILEPKGCOMS.PUTDEF 168033 . 170473) (FILES.PUTDEF 170475 . 171432) (VARS.PUTDEF 
171434 . 171577) (FILES.WHENCHANGED 171579 . 171699)) (173723 181156 (RENAME 173733 . 175134) (
CHANGECALLERS 175136 . 181154)) (181157 229105 (SHOWDEF 181167 . 181960) (COPYDEF 181962 . 184436) (
GETDEF 184438 . 186714) (GETDEFCOM 186716 . 187682) (GETDEFCOM0 187684 . 189030) (GETDEFCURRENT 189032
 . 195452) (GETDEFERR 195454 . 196755) (GETDEFFROMFILE 196757 . 201037) (GETDEFSAVED 201039 . 202143) 
(PUTDEF 202145 . 202848) (EDITDEF 202850 . 203827) (DEFAULT.EDITDEF 203829 . 206665) (EDITDEF.FILES 
206667 . 206868) (LOADDEF 206870 . 207046) (DWIMDEF 207048 . 207902) (DELDEF 207904 . 210918) (
DELFROMLIST 210920 . 211424) (HASDEF 211426 . 217748) (GETFILEDEF 217750 . 218272) (SAVEDEF 218274 . 
219933) (UNSAVEDEF 219935 . 220831) (COMPAREDEFS 220833 . 224135) (COMPARE 224137 . 224841) (TYPESOF 
224843 . 229103)) (229172 234215 (FIXEDITDATE 229182 . 232685) (EDITDATE? 232687 . 234213)) (234634 
243220 (FILEPKGCOM 234644 . 239577) (FILEPKGTYPE 239579 . 243218)) (255257 269759 (FINDCALLERS 255267
 . 255782) (EDITCALLERS 255784 . 263392) (EDITFROMFILE 263394 . 269074) (FINDATS 269076 . 269348) (
LOOKIN 269350 . 269757)) (269760 271487 (SEPRCASE 269770 . 271485)) (272004 277546 (IMPORTFILE 272014
 . 272988) (IMPORTEVAL 272990 . 273870) (IMPORTFILESCAN 273872 . 274293) (CHECKIMPORTS 274295 . 275631
) (GATHEREXPORTS 275633 . 276956) (\DUMPEXPORTS 276958 . 277544)) (277884 280092 (CLEARFILEPKG 277894
 . 280090)))))
STOP
\ No newline at end of file
diff --git a/sources/FILEPKG.~7~ b/sources/FILEPKG.~7~
deleted file mode 100644
index eae35d0e..00000000
--- a/sources/FILEPKG.~7~
+++ /dev/null
@@ -1,13 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 7-Mar-2020 14:09:52" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;7 284219 

      changes to%:  (VARS FILEPKGCOMS)

      previous date%: "18-Apr-2018 10:41:28" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;6)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020 by Venue & Xerox Corporation.  All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")

(PRETTYCOMPRINT FILEPKGCOMS)

(RPAQQ FILEPKGCOMS 
       [(COMS                                                (* ; 
            "standard records for accessing file  package type/command parts.  Exported for PRETTY")
              (VARS FILEPKGTYPEPROPS)
              (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
              (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
              (INITRECORDS * FILEPKGRECORDS))
        [DECLARE%: EVAL@COMPILE DOCOPY 

               (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.")

               (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES 
                                       PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS
                                       PRETTYFLG))
                  (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES 
                                       NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS]
        (INITVARS (MSDATABASELST))
        [COMS 
              (* ;; "making, adding, listing, compiling files")

              (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES 
                   FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE
                   ADDFILE0 LISTFILES)
              (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
                     (FILELST)
                     (LOADEDFILELST)
                     (NOTLISTEDFILES)
                     (NOTCOMPILEDFILES)
                     (MAKEFILEFORMS)
                     (NILCOMS))
              (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% 
                              F ST STF (REC . RC)
                              (BREC . RC)
                              (TC . C)
                              (BC . C)
                              (TCOMPL . C)
                              (BCOMPL . C)))
              (INITVARS (MAKEFILEREMAKEFLG T)
                     (CLEANUPOPTIONS '(RC]
        (COMS 
              (* ;; "scanning file coms")

              (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS 
                   FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM
                   INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                   IFCDECLARE INFILEPAIRS INFILECOMSMACRO))
        (COMS 
              (* ;; "adding to a file")

              (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM 
                   ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM)
              (INITVARS (DEFAULTCOMHASFILEFLG))
              (ADDVARS (MARKASCHANGEDFNS))
              (FNS MERGEINSERT MERGEINSERT1)
              (INITVARS [ADDTOFILEKEYLST (LIST '(%[ "" EXPLAINSTRING 
                                           "[ -- prettyprint the item to terminal and then ask again"
                                                    NOECHOFLG T)
                                               '(= "" EXPLAINSTRING "= - same as previous response" 
                                                   NOECHOFLG T)
                                               (LIST (CHARACTER (CHARCODE ^J))
                                                     ""
                                                     'EXPLAINSTRING 
                                                     "{line-feed} - same as previous response"
                                                     'NOECHOFLG T)
                                               '(%  " %
-" EXPLAINSTRING "{space} - no action" 
                                                    NOECHOFLG T)
                                               '(%] "Nowhere%
-" EXPLAINSTRING 
                                                    "] - nowhere, item is marked as a dummy%
-" 
                                                    NOECHOFLG T)
                                               '[%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG
                                                    T KEYLST (( "" CONFIRMFLG (%) %] %  %
-)
                                                                 RETURN
                                                                 (CDR ANSWER]
                                               '(@ "Near: " EXPLAINSTRING 
                                                 "@ other-item   -- put the item near the other item"
                                                   NOECHOFLG T KEYLST (( "" CONFIRMFLG (%
-)
                                                                          RETURN ANSWER)))
                                               (LIST (CHARACTER (CHARCODE ^M))
                                                     ""
                                                     'RETURN
                                                     '% )
                                               '("" "File name: " EXPLAINSTRING "a file name" KEYLST
                                                    (]
                     (LASTFILE)))
        (COMS 
              (* ;; "deleting an item from a file")

              (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE)
              (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
                 (MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
              (ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
        [COMS                                                (* ; 
                      "functions for doing things and marking them changed and auxiliary functions")
              (FNS SAVEPUT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
                                                     (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
              (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
              (ADDVARS (LISPXFNS (PUT . SAVEPUT)
                              (PUTPROP . SAVEPUT]
        (COMS                                                (* ; 
                                                  "sub-functions for file package commands & types")
              (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED 
                   MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS 
                   PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS 
                   FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS 
                   FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED)
              (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO)
                     (SYSPROPS PROPTYPE))
              (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT 
                    FILETYPE)
              (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS 
                    LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS 
                    PRETTYPRINTYPEMACROS USERMACROS))
        (COMS                                                (* ; 
                    "Define the commands below AFTER the various properties have been established.")
              (USERMACROS M))
        (COMS                                                (* ; "GETDEF methods")
              (FNS RENAME CHANGECALLERS)
              (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
                   GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF 
                   DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
              (INITVARS (WHEREIS.HASH)))
                                                             (* ; "Must come after PUTDEF")
        (FNS FIXEDITDATE EDITDATE?)
                                                             (* ; 
                                  "Edit date support for all kinds of definers (from PARC 6/10/92)")
        [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
              (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
        (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
        (COMS 
              (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")

              (FNS FILEPKGCOM FILEPKGTYPE)
              (PROP ARGNAMES FILEPKGCOM)
              (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
                     (FILEPKGTYPES FILEPKGCOMS))
              (FILEPKGCOMS FILEPKGCOMS)
              (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS
                     INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS
                     OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS))
        (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS)
                        (VARIABLES VARS CONSTANTS)))
        (INITVARS (SAVEDDEFS))
        (COMS                                                (* ; "EDITCALLERS")
              (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
              (FNS SEPRCASE)
              [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL]
              (INITVARS (SEPRCASEARRAYS)
                     (CLISPCASEARRAYS))
              (P (MOVD? 'INFILEP 'FINDFILE)
                                                             (* ; "or else from SPELLFILE"))
              (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
                             (NOLINKFNS LOADFROM)))
              (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS))
        (COMS                                                (* ; "EXPORT")
              (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS)
              (FILEPKGCOMS EXPORT)
              [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
                     (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"]
              (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM))
        (COMS                                                (* ; "for GAINSPACE")
              (FNS CLEARFILEPKG)
              [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                              ((Y "es")
                                               (N "o")
                                               (E . "verything")
                                               (F "ilemaps only%
-"]
              (GLOBALVARS SMASHPROPSLST1))
        (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT 
               DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 
               I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS 
               MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS 
               SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS)
        (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
                       (SPECVARS COMSNAME))
               (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
                      (NOLINKFNS . T)
                      (SPECVARS COMSNAME)
                      (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
               (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL 
                      INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                      IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
                      INFILECOMSPROP)
               (NIL MAKEFILE (LOCALVARS . T)
                    (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
               (ADDFILE ADDFILE ADDFILE0)
               (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
               (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
                    COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES 
                    EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM 
                    FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL 
                    LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS 
                    MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE 
                    POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
                    SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED 
                    UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS 
                                                 COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
                    (LOCALVARS . T))
               (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
               (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
                      GETDEFSAVED (RETFNS GETDEFCOM)
                      (NOLINKFNS . T)
                      (GLOBALVARS NOT-FOUNDTAG)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS 
                               MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP 
                               FILEPKGCOMPROPS PRETTYDEFMACROS)
                      (NLAML)
                      (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES])



(* ; "standard records for accessing file  package type/command parts.  Exported for PRETTY")


(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF CANFILEDEF FILEGETDEF))
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(DECLARE%: EVAL@COMPILE

(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
                                               (T (/REMPROP DATUM 'PRETTYTYPE]
                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
                                  (STANDARD [COND
                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
                                                                (OR (LISTP (GETTOPVAL 
                                                                                  'PRETTYDEFMACROS))
                                                                    (SETTOPVAL 'PRETTYDEFMACROS
                                                                           (LIST (LIST DATUM]
                                               (T (SETTOPVAL 'PRETTYDEFMACROS
                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
                                                                                'PRETTYDEFMACROS))
                                                                (GETTOPVAL 'PRETTYDEFMACROS]
                                         UNDOABLE
                                         (COND
                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
                                                                        (LIST (LIST DATUM]
                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
                                                                                   'PRETTYDEFMACROS))
                                                             (GETTOPVAL 'PRETTYDEFMACROS]
                                                             (* Not an atom record cause want 
                                                           REMPROP on NILs.)
                                                             (* NOTE%: PRETTCOM on PRETTY has 
                                                           open-coded access to the MACRO 
                                                           property.)
                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
                                       FILEPKGCONTENTS)))

(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
                                                           )
                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
                                                                              DATUM)))
                                                           (STANDARD (SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                      DATUM NEWVALUE)
                                                                                     )
                                                                            NEWVALUE)
                                                                  UNDOABLE
                                                                  (/SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                    DATUM NEWVALUE))
                                                                         NEWVALUE)))
                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
                                                                             DATUM)))
                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
                                                                               DATUM NEWVALUE))
                                                                       NEWVALUE)))
                                                    (ALLFIELDS NIL (/SETTOPVAL
                                                                    'PRETTYTYPELST
                                                                    (REMOVE (SEARCHPRETTYTYPELST
                                                                             DATUM)
                                                                           (GETTOPVAL 'PRETTYTYPELST]
                                                             (* NOTE%: PRETTYCOM on PRETTY has 
                                                           open-coded access to GETDEF property)
                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                                                                   (PUT X
                                                                                        'PROPTYPE
                                                                                        'FILEPKGCOMS]
                                         (ADDTOVAR PRETTYTYPELST))))

(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
                                                    UNDOABLE
                                                    (/PUTPROP DATUM 'FILE NEWVALUE])

(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))

(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
)

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST)
)

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(SEARCHPRETTYTYPELST
  [LAMBDA (TYPE FLG)                                     (* rmk%: " 3-JAN-82 22:55")
                                                             (* ; 
                                                           "access functions used by the records")
    (AND (LITATOM TYPE)
         (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X)
                                                               TYPE))
             (COND
                (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE
                                                                             'LST)
                                                                      TYPE NIL))
                                                      (GETTOPVAL 'PRETTYTYPELST]
                     (OR (LISTP (GETTOPVAL (CAR FLG)))
                         (/SETTOPVAL (CAR FLG)
                                NIL))
                     FLG])

(PRETTYDEFMACROS
  [NLAMBDA ARGS                                          (* lmm " 5-SEP-78 16:16")
                                                             (* ; 
                                                 "included so that old files will continue to load")
    (for X in ARGS collect (FILEPKGCOM (CAR X)
                                              'MACRO
                                              (CDR X])

(FILEPKGCOMPROPS
  [NLAMBDA PROPS
    (MAPC PROPS (FUNCTION (LAMBDA (Y)
                            (OR (MEMB Y SYSPROPS)
                                (SETQ SYSPROPS (CONS Y SYSPROPS)))
                            (PUT Y 'PROPTYPE 'FILEPKGCOMS])
)

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST)
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS 
                     *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG))

(CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS 
                     CLEANUPOPTIONS))
)

(RPAQ? MSDATABASELST )



(* ;; "making, adding, listing, compiling files")

(DEFINEQ

(CLEANUP
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (PROG (TEM1 TEM2 OPTIONS)
          (COND
             ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
              (SETQ OPTIONS (CAR FILES))
              (SETQ FILES (CDR FILES)))
             (T (SETQ OPTIONS CLEANUPOPTIONS)))
          (RETURN (APPEND (MAKEFILES OPTIONS FILES)
                         (COND
                            ((NOT (MEMB 'LIST OPTIONS))
                             NIL)
                            ((NULL FILES)
                             (LISTFILES))
                            ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES))
                                                             (* ; 
            "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.")
                             (APPLY 'LISTFILES TEM1)))
                         (COND
                            [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS]
                            ((NULL FILES)
                             (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES)
                                    (CDR TEM1))
                             TEM2)
                            ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES))
                             (COMPILEFILES0 TEM2 (CDR TEM1))
                             TEM2])

(COMPILEFILES
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (COND
       ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
        (COMPILEFILES0 (CDR FILES)
               (CAR FILES)))
       (T (COMPILEFILES0 FILES])

(COMPILEFILES0
  [LAMBDA (FILES OPTIONS)                                (* rmk%: "19-FEB-83 21:59")
    (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES)
       first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS))
                                (C (SETQ RCFLG NIL)
                                   (CDR OPTIONS))
                                (RC (CDR OPTIONS))
                                OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X)
                                                                           70 FILELST NIL X)
                                                                    (CAR X))
                                                        RCFLG OPTS X])

(CONTINUEDIT
  [LAMBDA (FILE)                                         (* bvm%: "30-Aug-86 15:09")
    (PROG (STREAM FL TEM FC ENV)
          (RESETLST
              [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT]
              (SETQ FILE (FULLNAME STREAM))
              (SETFILEPTR STREAM 0)
              (CL:MULTIPLE-VALUE-SETQ (ENV FC)
                     (\PARSE-FILE-HEADER STREAM 'RETURN)))
          (COND
             ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE]
              (LOADFROM FILE)                                (* ; 
                                                           "also calls addfile to notice the file.")
              ))
          (/replace FILECHANGES of FL with (FILECHANGES FC))
          [/replace FILEDATES of FL with
                                            (LIST (create FILEDATEPAIR
                                                         FILEDATE _ (CADR FC)
                                                         DATEFILENAME _ FILE)
                                                  (create FILEDATEPAIR
                                                         FILEDATE _
                                                         [CAR (SETQ TEM (CDR (MEMB 'date%: FC]
                                                         DATEFILENAME _ (CADR TEM]
          (RETURN FILE])

(MAKEFILE
  [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)           (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL;  LIST means list the FILE;  RC means RECOMPILE, C means COMPILEL;  --- for C AND RC assume ST unless next option is F.")

    (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS]
                           PRETTYFLG))
           (*PRINT-BASE* (if (EQ *PRINT-BASE* 8)
                             then 8
                           else                          (* ; "make sure radix is either 8 or 10, because all others don't read in like they print.  Maybe obsolete now with makefile environments")
                                 10))
           FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
          (DECLARE (CL:SPECIAL PRETTYFLG))
          (SETQ FILE (CAR Z))                                (* ; 
                                               "Necessary because FILE might have been misspelled.")
          (SETQ ROOTNAME (CADR Z))                           (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.")
          (SETQ FILEPROP (CDDR Z))
          (UPDATEFILES)                                  (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.")
          (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
          (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
          (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE))
      LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
                       (NULL FILEDATES))
              then                                       (* ; 
                   "File has never been loaded and never dumped i.e. user just set up COMS in core")
            elseif [OR (EQMEMB 'NEW OPTIONS)
                           (AND (NULL MAKEFILEREMAKEFLG)
                                (NOT (MEMB 'REMAKE OPTIONS]
              then (COND
                          ((AND (fetch LOADTYPE of FILEPROP)
                                (NEQ T (fetch LOADTYPE of FILEPROP)))
                           (LISPXPRIN2 FILE T T)
                           (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
                                           (LOADCOMP 
                                                  "the file was loaded for compilation purposes only")
                                           ((compiled Compiled COMPILED) 
                                                " -- only the compiled file has been loaded
")
                                           ((loadfns LOADFNS) 
                                                " -- only some of its symbolics have been loaded
")
                                           (SHOULDNT))
                                  T)
                           (COND
                              ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ")
                                    'Y)                      (* ; 
            "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.")
                               (GO OUT)))
                           (/replace LOADTYPE of FILEPROP with NIL)))
                    (SETQ SOURCEFILE NIL)
                    (SETQ REPRINTFNS NIL)
            elseif SOURCEFILE
              then                                       (* ; "source file given")
            elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T))
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
                                          (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE
                                                                              (fetch DATEFILENAME
                                                                                 of (CAR 
                                                                                            FILEDATES
                                                                                             ]
                                               (INFILEP SOURCEFILE)
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
              then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
                    (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
            elseif [AND (CDR FILEDATES)
                            [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
                            (EQUAL (FILEDATE SOURCEFILE)
                                   (fetch FILEDATE of (CADR FILEDATES]
              then 

                    (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.")

                    (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
                                         (fetch FILECHANGES of ROOTNAME)))
                    (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
            else (LISPXPRIN1 
                            '"can't find either the previous version or the original version of 
" T)
                  (LISPXPRIN2 FILE T T)
                  (LISPXPRIN1 '", so it will have to be written anew
" T)
                  (SETQ SOURCEFILE NIL)
                  (SETQ REPRINTFNS NIL)
                  (push OPTIONS 'NEW)
                  (SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
                  (GO LP0))
          (COND
             ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
                                          (LOADCOMP          (* ; 
                                                   "only loaded via LOADCOMP.  Need to do LOADFROM")
                                                    (LIST 'N SOURCEFILE "was loaded with LOADCOMP"
                                                          '- "LOADFROM it to obtain VARS/COMS"))
                                          (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%:
                                                                (fetch COMSNAME of FILEPROP))
                                                         (LIST 'Y "only compiled version of" ROOTNAME
                                                               
                                        "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions"
                                                               )))
                                          ((compiled loadfns) 
                                               (LIST 'N "Only some functions from" SOURCEFILE 
                                             "loaded via LOADFNS. Load all other expressions from it"
                                                     ))
                                          NIL)))
              (SELECTQ [ASKUSER DWIMWAIT (CAR Z)
                              (CDR Z)
                              '((Y "es
")
                                (N "o
")
                                (A "bort MAKEFILE
"]
                  (Y (SELECTQ (fetch LOADTYPE of FILEPROP)
                         (LOADCOMP                           (* ; 
                               "file was never actually loaded, just loadcomped.  thus no filecoms")
                                   (LOADFROM SOURCEFILE))
                         (Compiled 

                                 (* ;; "This is going to be a remake.  If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.")

                                   (LOADVARS 'DONTCOPY SOURCEFILE)
                                   (/replace LOADTYPE of FILEPROP with 'COMPILED)
                                                             (* ; "So wont have to be done again.")

                                 (* ;; "These are the only DECLARE:'s that are not also on the compiled file.  Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE:  Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)")

                                   )
                         ((loadfns compiled) 

                                 (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.")

                              (LOADVARS T SOURCEFILE))
                         NIL))
                  (A (GO OUT))
                  NIL)))
          (RESETLST
              [COND
                 ((MEMB 'NOCLISP OPTIONS)
                  (RESETSAVE PRETTYTRANFLG T))
                 ((MEMB 'CLISP%  OPTIONS)
                  (RESETSAVE PRETTYTRANFLG 'BOTH]
              (RESETSAVE %#UNDOSAVES)
              [COND
                 ((OR (MEMB 'CLISPIFY OPTIONS)
                      (MEMB 'CLISP OPTIONS))
                  (RESETSAVE CLISPIFYPRETTYFLG T))
                 ((OR (EQ FILETYPE 'CLISP)
                      (MEMB 'CLISP (LISTP FILETYPE)))
                  (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES]
              (for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
              (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
                                REPRINTFNS SOURCEFILE CHANGES)))
          (SETQ LASTFILE ROOTNAME)
          (/replace TOBEDUMPED of FILEPROP with NIL)
          (COND
             ((NOT (EQMEMB 'DON'TLIST FILETYPE))
              (pushnew NOTLISTEDFILES ROOTNAME)))
          (COND
             ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE))
              (pushnew NOTCOMPILEDFILES ROOTNAME)))
          [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL))
                                                 (SELECTQ OPT
                                                     (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                              (MAKEFILE1 FILE T (CDR TAIL))))
                                                     (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                             (MAKEFILE1 FILE NIL (CDR TAIL))))
                                                     (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
                                                                (APPLY 'LISTFILES (LIST FILE))))
                                                     (COND
                                                        ((MEMB OPT MAKEFILEOPTIONS))
                                                        ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL 
                                                                OPTIONS)
                                                         (GO $$LP))
                                                        (T (ERROR "Unrecognized MAKEFILE option" OPT]
          (RETURN FILE)
      OUT (RETURN (LIST FILE "-- MAKEFILE not performed."])

(FILECHANGES
  [LAMBDA (FILE TYPE)                                    (* bvm%: "30-Aug-86 15:08")

    (* ;; "If FILE is a list, it is assumed to be a file-created expressions;  otherwise, the filecreated expression is read from FILE.  If TYPE, returns the list of changed items of that type from the changes expression.  If TYPE=NIL, returns the whole list of typed change-lists")

    (PROG ([FCEXPR (OR (LISTP FILE)
                       (AND FILE (RESETLST
                                     (LET (OLDPTR STREAM)
                                          [if (SETQ STREAM (OPENP FILE 'INPUT))
                                              then (SETQ OLDPTR (GETFILEPTR STREAM))
                                                    (SETFILEPTR STREAM 0)
                                            else (RESETSAVE NIL (LIST 'CLOSEF
                                                                          (SETQ STREAM
                                                                           (OPENSTREAM FILE
                                                                                  'INPUT]
                                          (CL:MULTIPLE-VALUE-BIND (ENV FC)
                                                 (\PARSE-FILE-HEADER STREAM 'RETURN)
                                                 (if OLDPTR
                                                     then (SETFILEPTR STREAM OLDPTR))
                                                 FC)))]
           FNS CHANGES)
          (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR)))
                               (MEMB 'previous CHANGES)))
          [if (AND TYPE (NEQ TYPE 'FNS))
              then (RETURN (CDR (ASSOC TYPE CHANGES]
          (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM)))     (* ; 
                         "Old style changes expression listed FNS by name and other things by type")
          (RETURN (if TYPE
                      then                               (* ; "TYPE=FNS cause of test above.")
                            (NCONC FNS (CDR (ASSOC 'FNS CHANGES)))
                    elseif FNS
                      then (CONS (CONS 'FNS FNS)
                                     (SUBSET CHANGES (FUNCTION LISTP)))
                    else CHANGES])

(FILEPKG.MERGECHANGES
  [LAMBDA (C1 C2)                                        (* rmk%: "24-MAY-82 23:09")

    (* ;; "Merges 2 changes lists into a single one.  Treat LITATOM's as FNS, to accomodate old-style format on files.")

    (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND
                                                                                         E1)))
       in C2 do [COND
                           ((SETQ TEMP (ASSOC (CAR E2)
                                              VAL))
                            (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP))
                                           collect X)))
                           (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL])

(FILEPKG.CHANGEDFNS
  [LAMBDA (CHANGES)                                      (* rmk%: "20-MAY-82 22:00")

    (* ;; "Returns list of function names from a file-changes list.  Interprets old format (functions are atoms) and new format (with explicit type headers)")

    (CDR (ASSOC 'FNS CHANGES])

(MAKEFILE1
  [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES)            (* ; "Edited 29-Aug-89 11:46 by bvm")
    (PROG* ((ROOTNAME (ROOTFILENAME FILE))
            (COMPILER (COMPILE-FILE? ROOTNAME))
            GROUP)
           (COND
              ((AND (OR (EQ COMPILER 'BCOMPL)
                        (EQ COMPILER 'TCOMPL))
                    (NOT (FILEFNSLST ROOTNAME)))         (* ; 
                 "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.")
               (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
               (RETURN NIL)))
           (COND
              ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP))
                  suchthat (AND (NEQ X ROOTNAME)
                                    (OR (fetch TOBEDUMPED of (fetch FILEPROP of
                                                                                         X))
                                        (MEMB X OTHERFILES]

               (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled.  Wait.")

               (RETURN)))
           (LISPXPRIN1 '"
compiling " T)
           (LISPXPRINT (OR GROUP FILE)
                  T T)
           (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS)
                                                'ST)
                                            (EQ (CAR OPTIONS)
                                                'STF]
                             (FORGET-EXPRS? (EQ (CAR OPTIONS)
                                                'STF]
                            (SELECTQ COMPILER
                                ((FAKE-COMPILE-FILE)         (* ; 
                                               "The old CommonLispy interface to the ByteCompiler.")
                                     (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS
                                            (AND REDEFINE? (NOT FORGET-EXPRS?))))
                                ((CL:COMPILE-FILE)           (* ; "The new, improved (?) compiler")
                                     (CL:COMPILE-FILE FILE :LOAD (COND
                                                                    ((AND REDEFINE? (NOT 
                                                                                        FORGET-EXPRS?
                                                                                         ))
                                                                     :SAVE)
                                                                    (REDEFINE? T)
                                                                    (T NIL))))
                                ((TCOMPL BCOMPL)             (* ; "The old ByteCompiler")
                                     [IF (MEMB (CAR OPTIONS)
                                                   '(ST F S STF))
                                         THEN (LISPXUNREAD (LIST (CAR OPTIONS]
                                     [IF GROUP
                                         THEN 

                                               (* ;; 
                                   "File contained in FILEGROUP.  Therefore must be blockcompiled.")

                                               (IF RECOMPFLG
                                                   THEN (BRECOMPILE GROUP)
                                                 ELSE (BCOMPL GROUP))
                                       ELSEIF (EQ COMPILER 'TCOMPL)
                                         THEN (IF RECOMPFLG
                                                      THEN (RECOMPILE FILE)
                                                    ELSE (TCOMPL (LIST FILE)))
                                       ELSE (IF RECOMPFLG
                                                    THEN (BRECOMPILE FILE)
                                                  ELSE (BCOMPL (LIST FILE])
                                (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?...")))
                  T T])

(COMPILE-FILE?
  [LAMBDA (ROOTNAME)                                     (* ; "Edited 19-Jan-87 21:12 by Pavel")

(* ;;; "Which compiler should CLEANUP use?")

    (LET ((TYPE (GET ROOTNAME 'FILETYPE))
          (UNKNOWN NIL))
         (FOR X INSIDE TYPE DO (SELECTQ X
                                               ((TCOMPL :TCOMPL) 
                                                    (RETURN 'TCOMPL))
                                               ((BCOMPL :BCOMPL) 
                                                    (RETURN 'BCOMPL))
                                               ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) 
                                                    (RETURN 'FAKE-COMPILE-FILE))
                                               ((:COMPILE-FILE :XCL-COMPILE-FILE) 
                                                    (RETURN 'CL:COMPILE-FILE))
                                               ((CLISP) 
                                                    NIL)
                                               (SETQ UNKNOWN T))
            FINALLY (IF UNKNOWN
                            THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE
                                            ))
                  (RETURN *DEFAULT-CLEANUP-COMPILER*])

(MAKEFILES
  [LAMBDA (OPTIONS FILES)                                (* rmk%: "23-FEB-83 21:20")
    (RESETVARS (%#UNDOSAVES)                                 (* ; 
                                                   "Willing to save arbitrary amounts of undo info")
               (UPDATEFILES)
               [COND
                  ((NULL FILES)
                   (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE
                                                                         (COND
                                                                            ((NULL FLG)
                                                             (* ; "Gets printed the first time")
                                                                             
                                                                             '
                                        "****NOTE: the following are not contained on any file:
    ")
                                                                            (T '"    "]
                      do (SETQ FLG T) finally (AND FLG (ADDTOFILES?]
               (SETQ OPTIONS (MKLIST OPTIONS))
               (RETURN (for FILE inside (OR FILES FILELST)
                          when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP
                                                                          of (ROOTFILENAME FILE]
                          collect (LISPXPRIN2 FILE T T)
                                (LISPXPRIN1 '|...| T)
                                (PROG1 (MAKEFILE FILE OPTIONS)
                                       (LISPXTERPRI T])

(ADDFILE
  [LAMBDA (FILE LOADTYPE PRLST FCLST)                    (* bvm%: "29-Aug-86 12:22")

    (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           FLST VAL)
          [COND
             ((NOT FCLST)
              (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE)))
             [(NULL (CDR FCLST))                             (* ; "A simple symbolic file")
              (SETQ FCLST (CAR FCLST))
              (SETQ VAL (ADDFILE0 (COND
                                         ((LITATOM (CADR FCLST))
                                          (ROOTFILENAME (CADR FCLST)))
                                         (T ROOTNAME))
                               LOADTYPE FILE (CAR FCLST]
             (T 
                (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.")

                (SELECTQ LOADTYPE
                    ((T LOADFNS) 
                         (SETQ LOADTYPE 'Compiled))
                    (loadfns (SETQ LOADTYPE 'compiled))
                    (LOADCOMP                                (* ; 
                   "loadcomp on compiled file.  Don't notice since we don't know what its state is")
                              NIL)
                    (SHOULDNT))
                (for X in (CDR FCLST) when (LITATOM (CADR X))
                   do (push FLST (CADR X))
                         (OR (EQ LOADTYPE 'LOADCOMP)
                             (ADDFILE0 (ROOTFILENAME (CADR X))
                                    LOADTYPE
                                    (CADR X)
                                    (CAR X]
          (UPDATEFILES PRLST (OR FLST (LIST FILE)))
          [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES
                           when (AND (LITATOM TYPE)
                                         (SETQ CHANGED (fetch CHANGED of TYPE)))
                           do (/replace CHANGED of TYPE
                                     with (INTERSECTION (CDR (ASSOC TYPE PRLST))
                                                     CHANGED]
          (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS))
          (RETURN VAL])

(ADDFILE0
  [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT)               (* lmm "28-Nov-84 16:47")
    (PROG (COMS X FILEPROP FLG TEM)
      TOP (SETQ COMS (FILECOMS ROOTNAME))
          [COND
             ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME))
              (COND
                 ([AND LOADTYPE (FMEMB LOADTYPE
                                       (CDR (FMEMB (fetch LOADTYPE of FILEPROP)
                                                   '(LOADCOMP loadfns compiled Compiled LOADFNS 
                                                           COMPILED NIL T]
                  (/replace LOADTYPE of FILEPROP with LOADTYPE)

                  (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property.  'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file.  'Compiled' means all but DECLARE: expressions are in.  e.g. user does LOAD of a compiled file.  COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.  LOADFNS means everything in, e.g. user des LOADFROM symbolic file.  COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted.  NIL is a makefile when coms were set up in core.  T is full load of symbolic file.  The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.")

                  (* ;; "LOADCOMP means file was loadcomp'ed.  note that the actual structure is a tree, not a list, and the above is only an approximation.  if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc.  however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.")

                  (GO OUT))
                 (T (GO OUT1]
          (COND
             [(OR LOADTYPE (LISTP (GETTOPVAL COMS)))
              (SETQ FILEPROP (/replace FILEPROP of ROOTNAME
                                with (create FILEPROP
                                                COMSNAME _ COMS
                                                LOADTYPE _ LOADTYPE]
             (FLG (GO ERROR))
             ((AND DWIMFLG (EQ ROOTNAME FULLNAME)
                   (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T)))

              (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.")

              (SETQ FULLNAME ROOTNAME)
              (SETQ FLG T)                                   (* ; 
                                         "so wont try to spelling correct again if file isnt there")
              (GO TOP))
             (T (GO ERROR)))
      OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME
                               with (LIST (create FILEDATEPAIR
                                                     FILEDATE _ DAT
                                                     DATEFILENAME _ FULLNAME]
          (AND (EQ LOADTYPE T)
               (/replace TOBEDUMPED of FILEPROP with NIL))
      OUT1
          [COND
             ([AND (LISTP (GETTOPVAL COMS))
                   (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ; 
                                                          "coms wuld not be set up on a loadccomp.")
              (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST]
          (RETURN (COND
                     ((NULL LOADTYPE)                        (* ; "call from makefile.")
                      (CONS FULLNAME (CONS ROOTNAME FILEPROP)))
                     (T FILEPROP)))
      ERROR
          (ERROR FULLNAME "not file name." T])

(LISTFILES
  [NLAMBDA FILES                                         (* rmk%: " 3-Dec-84 08:58")
    (DECLARE (GLOBALVARS NOTLISTEDFILES))                (* ; "LISTFILES1 is machinedependent")
    (for FILE FULLNAME OPTIONS in (COND
                                             (FILES (SETQ FILES (NLAMBDA.ARGS FILES)))
                                             (T NOTLISTEDFILES))
       when (COND
                   ((LISTP FILE)
                    (SETQ OPTIONS (APPEND FILE OPTIONS))
                    NIL)
                   ((SETQ FULLNAME (FINDFILE FILE))
                    FULLNAME)
                   (T (printout T FILE " not found." T)
                      NIL)) collect [COND
                                           ((LISTFILES1 FULLNAME OPTIONS)
                                            (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
                                                                        NOTLISTEDFILES]
                                  FULLNAME])
)

(RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)

(RPAQ? FILELST )

(RPAQ? LOADEDFILELST )

(RPAQ? NOTLISTEDFILES )

(RPAQ? NOTCOMPILEDFILES )

(RPAQ? MAKEFILEFORMS )

(RPAQ? NILCOMS )

(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP%  F ST STF
                                 (REC . RC)
                                 (BREC . RC)
                                 (TC . C)
                                 (BC . C)
                                 (TCOMPL . C)
                                 (BCOMPL . C))

(RPAQ? MAKEFILEREMAKEFLG T)

(RPAQ? CLEANUPOPTIONS '(RC))



(* ;; "scanning file coms")

(DEFINEQ

(FILEPKGCHANGES
  [LAMBDA N                                              (* Pavel " 7-Oct-86 19:22")
    (COND
       [(EQ N 0)
        (PROG (TEM)
              (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X)
                                                                   (SETQ TEM (FILEPKGCHANGES
                                                                              X)))
                         collect (CONS X TEM]
       [(EQ (ARG N 1)
            T)
        (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES
                                                                                 X]
       [(EQ N 1)
        (COND
           [(LISTP (ARG N 1))
            (for X in (ARG N 1) when (FMEMB (CAR X)
                                                        FILEPKGTYPES)
               do (/replace CHANGED of (CAR X) with (CDR X]
           (T (for Y on (fetch CHANGED of (ARG N 1))
                 when [AND (CAR Y)
                               (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y)
                                                                                 Z]
                 collect (CAR Y]
       (T (/replace CHANGED of (ARG N 1) with (ARG N 2])

(GETFILEPKGTYPE
  [LAMBDA (TYPE ONLY NOERROR NAME)                       (* lmm "20-Nov-86 23:10")

    (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ")

    (COND
       [(LISTP TYPE)

        (* ;; " given a list of types, coerce them all or return NIL")

        (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME)
                                               (RETURN]
       ((EQ TYPE '?)

        (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ")

        (AND NAME (TYPESOF NAME)))
       [(AND (NEQ ONLY 'COMS)
             (OR (SELECTQ TYPE
                     (NIL 'FNS)
                     (T 'VARS)
                     NIL)
                 (for X in FILEPKGTYPES do (if (EQ TYPE X)
                                                           then 

                                                                 (* ;; "type matched exactly")

                                                                 (RETURN TYPE)
                                                         elseif (AND (LISTP X)
                                                                         (EQ TYPE (CAR X)))
                                                           then (RETURN (CDR X]
       [(AND (NEQ ONLY 'TYPE)
             (LITATOM TYPE)
             (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST))       (* ; "Prefer an exact match quickly")
                    ]
       [(AND (NEQ ONLY 'COMS)
             (LITATOM TYPE)
             (for X in FILEPKGTYPES bind NAME
                do (SETQ NAME (if (NLISTP X)
                                      then X
                                    else (CAR X))) 

                      (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization")

                      (AND (<= 0 (- (NCHARS NAME)
                                    (NCHARS TYPE))
                               1)
                           (STRPOS TYPE NAME)
                           (RETURN (if (EQ X NAME)
                                       then X
                                     else (CDR X]
       [(FIXSPELL TYPE NIL (SELECTQ ONLY
                               (TYPE FILEPKGTYPES)
                               (COMS FILEPKGCOMSPLST)
                               (UNION FILEPKGTYPES FILEPKGCOMSPLST]
       ((NOT NOERROR)
        (ERROR (SELECTQ ONLY
                   (TYPE "unrecognized manager definition type")
                   (COMS "unrecognized manager command")
                   "unrecognized manager definition-type/command")
               TYPE])

(MARKASCHANGED
  [LAMBDA (NAME TYPE REASON)                             (* ; "Edited 25-May-88 15:37 by drc:")
    (COND
       (FILEPKGFLG (SETQ REASON (SELECTQ REASON
                                    ((CLISP LOAD CHANGED DEFINED DELETED) 
                                         REASON)
                                    (NIL 'CHANGED)
                                    (T 'DEFINED)
                                    (ERROR "bad REASON in MARKASCHANGED" REASON)))
              (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (for FN inside (fetch WHENCHANGED of TYPE)
                 do (APPLY* FN NAME TYPE REASON))
              (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON))
              [COND
                 ((EQ REASON 'DELETED)
                  (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L)
                                                                                    NAME)
                     do (/RPLACA L NIL))                 (* ; 
                                                          "unmark as changed and remove from files")
                  (DELFROMFILES NAME TYPE))
                 (T (LET ((LST (push (fetch CHANGED of TYPE)
                                      NAME)))
                         (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST)
                                               LISPXHIST))   (* ; 
                             "UNDO by smashing with NIL;  makes calls to MARKASCHANGED independent")
                         ]
              NAME])

(FILECOMS
  [LAMBDA (FILE X)                                       (* rmk%: "19-FEB-83 13:55")
    (COND
       ((AND (NULL FILE)
             (NULL X))
        'NILCOMS)
       [(AND (OR (NULL X)
                 (EQ X 'COMS))
             (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE]
       (T (PACK* (NAMEFIELD FILE)
                 (OR X 'COMS])

(WHEREIS
  [LAMBDA (NAME TYPE FILES FN)                        (* ; "Edited 12-Jul-88 17:14 by MASINTER")

    (* ;; "T as a NAME has a special meaning to INFILECOMS?  so don't pass through.")

    (CL:UNLESS (EQ NAME T)
        (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES)
                                           FILELST)
                                      (FUNCTION (LAMBDA (FILE)
                                                  (INFILECOMS? NAME TYPE (FILECOMS FILE]
                               (AND (EQ FILES T)
                                    (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS)
                                    (LET ((FILES NIL))
                                         (for TY inside TYPE
                                            do (for FILE-NAME
                                                      in (XCL::HASH-FILE-WHERE-IS NAME
                                                                    (GETFILEPKGTYPE TYPE))
                                                      do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME))
                                                                    FILES)))
                                         (REVERSE FILES]
             (CL:IF FN
                 [MAPC IN-FILES (FUNCTION (LAMBDA (FILE)
                                            (APPLY* FN NAME FILE]
                 IN-FILES)))])

(SMASHFILECOMS
  [LAMBDA (FILE)                                         (* rmk%: "19-FEB-83 22:15")
    (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X)
       do (SETTOPVAL X 'NOBIND))
    FILE])

(FILEFNSLST
  [LAMBDA (FILE)                                         (* ; "Edited 14-Jun-90 19:30 by jds")
    (FILECOMSLST FILE '(FUNCTIONS FNS])

(FILECOMSLST
  [LAMBDA (FILE TYPE FLG)                                (* JonL "24-Jul-84 19:48")
                                                             (* ; 
                                                    "TYPE is coerced in the innards of INFILECOMS?")
    (COND
       ((EQ FLG 'UPDATE)
        (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE)
                    FLG)))
       (T (INFILECOMS? NIL TYPE (FILECOMS FILE)
                 FLG])

(UPDATEFILES
  [LAMBDA (PRLST FLST)                                   (* rmk%: "19-FEB-83 14:27")

    (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g.  LOAD, LOADFNS) involving the files in FLST began.")

    (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE))
       do (COND
                 ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE)))
                                                             (* ; 
                                                           "FILEPKGCHANGES eliminates duplicates")
                  (/replace CHANGED of TYPE with NIL))
                 (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES
                           (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST
                       first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) 

                             (* ;; "First check NIL=Nowhere.  LST:1 contains variables whose values are on the file literally.  These are `found' but not marked.  LST::1 contains all other items.")

                             (SETQ FOUND (NCONC (CAR LST)
                                                (CDR LST)
                                                FOUND))
                       do (SETQ PCHANGES (COND
                                                ((FMEMB (fetch DATEFILENAME
                                                           of (CAR (fetch FILEDATES
                                                                          of FILE)))
                                                        FLST)

                                 (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began.  Thus, by this intersection we only worry about items that were previously changed;  any items that were only changed during this operation are ignored.")

                                                 (INTERSECTION CHANGED PREVITEMS))
                                                (T CHANGED)))
                             [COND
                                ([AND PCHANGES [SETQ COMS (fetch COMSNAME
                                                             of (SETQ FILEPROP
                                                                     (LISTP (fetch FILEPROP
                                                                               of FILE]
                                      (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE]

                                 (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms")

                                 [COND
                                    ((CDR LST)               (* ; "CDR items must be distributed")
                                     [COND
                                        ((NULL (fetch TOBEDUMPED of FILEPROP))

                                         (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL")

                                         [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL
                                                                                   'NOTLISTEDFILES]
                                         (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE
                                                                              (GETTOPVAL 
                                                                                     '
                                                                                     NOTCOMPILEDFILES
                                                                                     ]
                                                             (* ; 
                                                   "Get the (possibly new) TYPE item list to smash")
                                     [COND
                                        [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED
                                                                        of FILEPROP]
                                        (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE]
                                                             (* ; 
                                                        "Now distribute items to the file property")
                                     (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP)
                                                                                   )
                                        do (/NCONC1 TYPEDPROP Y]
                                 (SETQ FOUND (NCONC (CAR LST)
                                                    (CDR LST)
                                                    FOUND] finally (/replace CHANGED
                                                                          of TYPE
                                                                          with (LDIFFERENCE
                                                                                    CHANGED FOUND])

(INFILECOMS?
  [LAMBDA (NAME TYPE COMS ONFILETYPE)                 (* ; "Edited 12-Jul-88 17:42 by MASINTER")

    (* ;; "Returns T if NAME is 'CONTAINED' in COMS.  If NAME is NIL, then value is a list of all of the functions contained in COMS.  If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.)  Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1.  while elements are the subset of NAME which are on the file in other case")

    (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS?  returns the dotted pair of (literals  . elements) where literals are those which are `literally' on the file (e.g.  (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")

    (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ")

    (PROG (VAL LITERALS ORIGFLG)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (SELECTQ ONFILETYPE
              (EDIT (SELECTQ TYPE
                        (FILEVARS (RETURN))
                        NIL))
              NIL)
          [COND
             ((LITATOM COMS)
              (SELECTQ TYPE
                  ((VARS FILEVARS)                           (* ; 
                                                           "the COMS of a file are also on it")
                       (INFILECOMSVAL COMS))
                  NIL)
              (SETQ COMS (EVALV COMS]
          (INFILECOMS COMS)
          (SETQ VAL (DREVERSE VAL))
          (RETURN (COND
                     ((EQ ONFILETYPE 'UPDATE)
                      (CONS LITERALS VAL))
                     (T VAL])

(INFILECOMTAIL
  [LAMBDA (COM FLG)                                   (* ; "Edited  2-Aug-88 02:15 by masinter")
    [SETQ COM (COND
                 ((EQ (CADR COM)
                      '*)
                  (COND
                     [(LITATOM (CADDR COM))
                      (LISTP (EVALV (CADDR COM]
                     (T [RESETVARS (DWIMLOADFNSFLG)
                                   (NLSETQ (SETQ COM (EVAL (CADDR COM]
                        COM)))
                 (T (CDR COM]
    (if (NOT FLG)
        then (for X in COM
                    do [if (AND (LISTP X)
                                        (EQ (CAR X)
                                            COMMENTFLG))
                               then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X)
                                                                        (OR (NLISTP X)
                                                                            (NEQ (CAR X)
                                                                                 COMMENTFLG]
                    finally (RETURN COM))
      else COM])

(INFILECOMS
  [LAMBDA (COMS)                                         (* rmk%: "19-FEB-83 22:17")
    (for X in COMS do (INFILECOM X])

(INFILECOM
  [LAMBDA (COM)                                       (* ; "Edited  2-Aug-88 02:27 by masinter")
    (COND
       [(NLISTP COM)
        (COND
           ((EQ TYPE 'VARS)
            (INFILECOMSVAL COM]
       ((EQ (CAR COM)
            COMMENTFLG)

        (* ;; 
"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
                                                             (* ; 
  "don't know why I should bother, but someone might want to know all of the comments on a file???")
        (COND
           ((EQ TYPE COMMENTFLG)
            (INFILECOMSVAL COM T)))
        NIL)
       (T
        (PROG ((COMNAME (CAR COM))
               (TAIL (CDR COM))
               CFN TEM)
              (COND
                 [[COND
                     ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
                      (SETQ TEM (APPLY* CFN COM (COND
                                                   ((AND (NULL ONFILETYPE)
                                                         (NOT (CL:SYMBOLP NAME)))
                                                             (* ; 
                                                "call from WHEREIS of a name which is not a symbol")
                                                    (LIST NAME))
                                                   (T NAME))
                                       TYPE ONFILETYPE)))
                     ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
                                                             (* ; "for compatability")
                      (SETQ TEM (APPLY* CFN COM TYPE NAME]
                  (COND
                     [(NLISTP TEM)
                      (COND
                         ((EQ TEM T)
                          (COND
                             ((OR (EQ NAME T)
                                  (NULL ONFILETYPE))
                              (RETFROM 'INFILECOMS? T]
                     (T (INFILECOMSVALS TEM]
                 ((LISTP TAIL)

                  (* ;; "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")

                  (SELECTQ COMNAME
                      ((PROP IFPROP) 
                           (SETQ TAIL (CDR TAIL)))
                      NIL)
                  [COND
                     ((EQ (CAR TAIL)
                          '*)
                      (COND
                         ((LITATOM (CADR TAIL))
                          (SELECTQ TYPE
                              ((VARS FILEVARS) 
                                   (INFILECOMSVAL (CADR TAIL)))
                              NIL))
                         ((AND (LISTP (CADR TAIL))
                               (EQ ONFILETYPE 'UPDATE)
                               (EQ TYPE 'VARS)
                               (EQ (CAADR TAIL)
                                   'PROGN)
                               (FMEMB (CAR (LAST (CADR TAIL)))
                                      NAME))
                          (SETQ VAL (CONS (CADR TAIL)
                                          VAL]
                  (SELECTQ COMNAME
                      ((COMS EXPORT) 
                           (INFILECOMS (INFILECOMTAIL COM T)))
                      (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM)
                                                           T)))
                      (DECLARE%:                             (* ; "skip over DECLARE: tags")
                                 [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM))
                                              (IFCDECLARE (INFILECOMTAIL COM)
                                                     (EQ TYPE 'DECLARE%:])
                      (ORIGINAL                              (* ; "dont expand macros")
                                (PROG ((ORIGFLG T))
                                      (INFILECOMS (INFILECOMTAIL COM T))))
                      ((PROP IFPROP)                         (* ; 
                                       "this currently does not handle `pseudo-types' of PROPNAMES")
                           (SELECTQ TYPE
                               (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM)
                                                              T)
                                             (CADR COM)))
                               (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
                                              (CADR COM)))
                               NIL))
                      (PROPS (RETURN (IFCPROPS COM)))
                      (MACROS (RETURN (SELECTQ TYPE
                                          (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T)
                                                        MACROPROPS))
                                          (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T)))
                                          NIL)))
                      (ALISTS                                (* ; 
                      "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")
                              (RETURN (SELECTQ TYPE
                                          (ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
                                          NIL)))
                      (P [RETURN (SELECTQ TYPE
                                     ((EXPRESSIONS P) 
                                          (INFILECOMSVALS (INFILECOMTAIL COM T)
                                                 T))
                                     (COND
                                        ((NULL ONFILETYPE)   (* ; "for WHEREIS and FILECOMSLST")
                                         (SELECTQ TYPE
                                             (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR))
                                             (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE))
                                             NIL])
                      ((ADDVARS APPENDVARS) 
                           (SELECTQ TYPE
                               (VARS [RETURN (AND (NULL ONFILETYPE)
                                                  (for X in (INFILECOMTAIL COM T)
                                                     do (INFILECOMSVAL (CAR X)
                                                                   T])
                               (ALISTS [RETURN (for X in (INFILECOMTAIL COM T)
                                                  when (EQMEMB 'ALIST (GETPROP (CAR X)
                                                                                 'VARTYPE))
                                                  do (for Z in (CDR X)
                                                            do (INFILECOMSVAL
                                                                    (LIST (CAR X)
                                                                          (CAR Z))
                                                                    T])
                               (OR (EQ TYPE COMNAME)
                                   (RETURN))))
                      ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) 
                           [RETURN (COND
                                      ((EQ TYPE 'EXPRESSIONS)
                                       (for X in (INFILECOMTAIL COM T)
                                          when (AND (LISTP X)
                                                        (NEQ (CAR X)
                                                             COMMENTFLG))
                                          do (INFILECOMSVAL (CONS 'SETQ X)
                                                        T)))
                                      ((OR (EQ TYPE 'VARS)
                                           (EQ TYPE COMNAME))(* ; 
                   "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
                                       (for X in (INFILECOMTAIL COM T)
                                          do (COND
                                                    ((LISTP X)
                                                     (AND (CAR X)
                                                          (NEQ (CAR X)
                                                               COMMENTFLG)
                                                          (INFILECOMSVAL (CAR X)
                                                                 T)))
                                                    (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS])
                      (DEFS [RETURN (for X in (INFILECOMTAIL COM T)
                                       when (EQ TYPE (CAR X)) do (INFILECOMSVALS
                                                                          (CDR X])
                      (FILES (RETURN))
                      NIL)

                  (* ;; "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")

                  (COND
                     ((EQ COMNAME TYPE)
                      (INFILECOMSVALS (INFILECOMTAIL COM T)))
                     [(AND (LISTP TYPE)
                           (FMEMB COMNAME TYPE))
                      (LET ((TYPE COMNAME))
                           (INFILECOMSVALS (INFILECOMTAIL COM T]
                     ((AND (OR (NULL CFN)
                               (AND (EQ CFN T)
                                    (NULL ONFILETYPE)))
                           (NULL ORIGFLG)
                           (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
                      (INFILECOMS (SUBPAIR (CAR TEM)
                                             (INFILECOMTAIL COM T)
                                             (CDR TEM])

(INFILECOMSVALS
  [LAMBDA (X FLG)                                     (* ; "Edited  2-Aug-88 02:21 by masinter")
    (for Y in X when (NOT (AND (LISTP Y)
                                           (EQ (CAR Y)
                                               COMMENTFLG))) do (INFILECOMSVAL Y FLG])

(INFILECOMSVAL
  [LAMBDA (X FLG)                                     (* ; "Edited 12-Jul-88 17:56 by MASINTER")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND (OR (NULL NAME)
                 (MEMBER X NAME))
             (COND
                (FLG (SETQ LITERALS (CONS X LITERALS)))
                (T (SETQ VAL (CONS X VAL]
       ((AND (EQ ONFILETYPE 'EDIT)
             FLG)                                            (* ; 
                                        "literals should not be edited as they are on the fileCOMS")
        NIL)
       ((EQ ONFILETYPE 'TYPESOF)
        (AND (COND
                ((LITATOM NAME)
                 (EQ NAME X))
                (T (EQUAL NAME X)))
             (CL:PUSHNEW TYPE VAL)))
       ([OR (EQ NAME T)
            (COND
               ((LITATOM NAME)
                (EQ NAME X))
               (T (EQUAL NAME X]
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS X VAL])

(INFILECOMSPROP
  [LAMBDA (AT PROP)                                      (* lmm "25-SEP-81 17:15")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND [OR (NULL NAME)
                 (find X in NAME suchthat (AND (EQ (CAR X)
                                                               AT)
                                                           (EQ (CADR X)
                                                               PROP]
             (SETQ VAL (CONS (LIST AT PROP)
                             VAL]
       ((OR (EQ NAME T)
            (AND (EQ (CAR NAME)
                     AT)
                 (EQ (CADR NAME)
                     PROP)))
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS (LIST AT PROP)
                        VAL])

(IFCPROPS
  [LAMBDA (COM)                                          (* bvm%: " 2-Dec-83 14:24")

(* ;;; "Examine a PROPS com for objects of specified TYPE")

    (SELECTQ TYPE
        (PROPS                                               (* ; 
                                       "the PROPS command can actually take (PROPNAME at1 at2 ...)")
               (INFILEPAIRS (INFILECOMTAIL COM)))
        (PROP                                                (* ; 
                                                "return the atoms which have any properties at all")
              (for PAIR in (INFILECOMTAIL COM) do (for ATNAME
                                                                     inside (CAR PAIR)
                                                                     do (INFILECOMSVAL ATNAME
                                                                                   ))))
        (MACROS                                              (* ; "only MACRO properties")
                (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR)
                                                                           (CDR PAIR))))
        NIL])

(IFCEXPRTYPE
  [LAMBDA (COM FN)                                       (* ; "Edited  6-Apr-87 20:20 by Pavel")

(* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN")

    (for SUBCOM in (INFILECOMTAIL COM)
       when (AND (EQ (CAR SUBCOM)
                         FN)
                     (EQ (CAR (LISTP (CADR SUBCOM)))
                         'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM))
                                                T])

(IFCPROPSCAN
  [LAMBDA (ATOMS PROPNAMES)                           (* ; "Edited  2-Aug-88 02:20 by masinter")

(* ;;; 
"Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES")

    (for AT in ATOMS WHEN (LITATOM AT) unless [COND
                                                                 [(EQ ONFILETYPE 'UPDATE)
                                                                  (COND
                                                                     (NAME (NOT (ASSOC AT NAME]
                                                                 ((LISTP NAME)
                                                                  (NEQ AT (CAR NAME]
       do (COND
                 ((EQ PROPNAMES 'ALL)
                  (for PROP in (GETPROPLIST AT) by (CDDR PROP)
                     when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP)))
                 (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])

(IFCDECLARE
  [LAMBDA (TAIL WANTDECLARE)                          (* ; "Edited  8-Jun-90 18:11 by teruuchi")
    (PROG ((TAIL TAIL))
      LP  (COND
             ((LISTP TAIL)
              [SELECTQ (CAR TAIL)
                  ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                       [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
                                                                 (CADR TAIL]
                       (SETQ TAIL (CDR TAIL)))
                  (DONTEVAL@LOAD [COND
                                    ((OR (\STKSCAN 'DOFILESLOAD)
                                         (\STKSCAN 'LOAD))
                                                  (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"")
                                     (RETURN))
                                    (WANTDECLARE (INFILECOMSVAL (CAR TAIL])
                  (COMPILERVARS (RETURN))
                  (COND
                     [(FMEMB (CAR TAIL)
                             DECLARETAGSLST)
                      (COND
                         (WANTDECLARE (INFILECOMSVAL (CAR TAIL]
                     (T (INFILECOM (CAR TAIL]
              (SETQ TAIL (CDR TAIL))
              (GO LP])

(INFILEPAIRS
  [LAMBDA (LST)                                          (* lmm " 4-DEC-78 09:51")
    (for LL in LST do (for X inside (CAR LL)
                                     do (for Y inside (CDR LL)
                                               do (INFILECOMSVAL (LIST X Y])

(INFILECOMSMACRO
  [LAMBDA (ATS PROPS)                                    (* lmm "28-SEP-78 18:35")

    (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.  --- Normally (e.g.  for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom.  However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties")

    (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE)
                                               (EVERY (PROPNAMES AT)
                                                      (FUNCTION (LAMBDA (X)
                                                                  (OR (NOT (FMEMB X MACROPROPS))
                                                                      (EQMEMB X PROPS]
                                           [SOME MACROPROPS (FUNCTION (LAMBDA (PROP)
                                                                        (EQMEMB PROP PROPS]
                                           (INFILECOMSVAL AT])
)



(* ;; "adding to a file")

(DEFINEQ

(FILES?
  [LAMBDA NIL                                            (* bvm%: "27-Oct-86 18:14")

(* ;;; 
"Display each file needing dumping, etc.  For files needing dumping, display details of why.")

    (UPDATEFILES)
    (LET (FILES CHANGES PRINTED)
         (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED
                                                                of (LISTP (fetch FILEPROP
                                                                                 of FILE]
            do (if (NOT PRINTED)
                       then (LISPXPRIN1 "To be dumped:
" T)
                             (SETQ PRINTED T))
                  (LISPXPRIN2 FILE T)
                  (LISPXPRIN1 " ...changes to " T)
                  [for CH in CHANGES bind TB
                     do (COND
                               ((LISTP CH)
                                [COND
                                   (TB (LISPXTAB TB NIL T))
                                   (T (SETQ TB (POSITION T]
                                (LISPXPRIN2 (CAR CH)
                                       T)
                                (FILES?PRINTLST (CDR CH)))
                               (T                            (* ; "old style")
                                  (LISPXPRIN2 CH T)
                                  (LISPXSPACES 1 T]
                  (LISPXTERPRI T))
         (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED "    plus "))
            do (SETQ FLG T) finally (if FLG
                                                then (OR PRINTED (LISPXPRIN1 "...to be dumped.  "
                                                                            T))
                                                      (ADDTOFILES?)))
         (if (SETQ FILES NOTCOMPILEDFILES)
             then (FILES?PRINTLST FILES "To be compiled: ")
                   (LISPXTERPRI T))
         (if (SETQ FILES NOTLISTEDFILES)
             then (FILES?PRINTLST FILES "To be listed: ")
                   (LISPXTERPRI T))
         (CL:VALUES])

(FILES?1
  [LAMBDA (TYPE FIRST)                                   (* bvm%: "27-Oct-86 18:17")

    (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.")

    (LET (STR LST)
         (COND
            ([AND (LITATOM TYPE)
                  (SETQ STR (fetch DESCRIPTION of TYPE))
                  (LISTP (SETQ LST (fetch CHANGED of TYPE]
             (AND FIRST (LISPXPRIN1 FIRST T))
             (LISPXPRIN1 '"the " T)
             (LISPXPRIN1 STR T)
             (FILES?PRINTLST LST)
             (LISPXTERPRI T)
             T])

(FILES?PRINTLST
  [LAMBDA (LST STR)                                      (* bvm%: "27-Oct-86 18:15")

    (* ;; "Print elements of LST separated by commas and indenting new lines a bunch.  If MAPRINT had a left margin arg, this would be simpler.")

    (MAPRINT LST T (OR STR ": ")
           NIL ", " [FUNCTION (LAMBDA (STR)
                                (COND
                                   ((> (+ (POSITION T)
                                          (NCHARS STR T T)
                                          3)
                                       (LINELENGTH NIL T))
                                    (LISPXTERPRI T)
                                    (LISPXPRIN1 "         " T)))
                                (LISPXPRIN2 STR T T]
           T])

(ADDTOFILES?
  [LAMBDA (NOASKSTR)                                     (* ; "Edited 21-Aug-91 10:13 by jds")

    (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says")

    (ERSETQ
     (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS]

      (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g.  changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES")

           [COND
              (NOASKSTR (PRIN1 NOASKSTR T))
              (T (DOBE)
                 (SETQ BUFS (READP T))
                 (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go")
                                 '((Y "es
")
                                   (N "o
")
                                   (%] "Nowhere
" EXPLAINSTRING "] - nowhere, all items will be marked as dummy
" NOECHOFLG T))
                                 T)
                     (N (RETURN))
                     (%] (for TYPE in FILEPKGTYPES
                            do (for NAME in (fetch (FILEPKGTYPE CHANGED)
                                                           of TYPE)
                                      do (ADDTOFILE NAME TYPE NIL)))
                         (RETURN))
                     NIL)                                    (* ; 
                              "if there was type-ahead BEFORE the askuser, then don't allow it now")
                 (COND
                    (BUFS (SETQ BUFS (COND
                                        ((READP T)
                                         (LINBUF)
                                         (SYSBUF)
                                         (SETQ BUFS (CLBUFS NIL T READBUF]
           [for TYPE STR LST in FILEPKGTYPES
              when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
                            (LISTP (SETQ LST (COND
                                                ((EQ TYPE 'VARS)
                                                 VARSCHANGES)
                                                (T (fetch (FILEPKGTYPE CHANGED) of TYPE]
              do
              (printout T "(" STR ")" T)
              (for NAME TEM FILE in LST when NAME
                 do
                 (PROG NIL
                   LP  (PRIN2 NAME T)
                       (SPACES 2 T)

                  (* ;; "if user typed ahead before entering addtofiles??  then dont allow typeahead here, because it will justgobble his earlier typeahead.")

                       (SELECTQ (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T))
                           (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)

                                 (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer")

                                              (DOBE)))
                               (GO LP))
                           (%] (SETQ FILE))
                           (%                                (* ; "space.  means no action")
                               (RETURN))
                           (%
 (PRINT (OR (SETQ FILE LASTFILE)
            'Nowhere)
        T))
                           (SETQ FILE TEM))
                       (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
                                         (SETQ PLACE (WHATIS FILE NIL TYPE))
                                         [COND
                                            ((LITATOM PLACE) (* ; "file name")
                                             (SETQ FILE PLACE)
                                             (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                                                        NAME TYPE NEAR LISTNAME)
                                                 (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                          (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.")

                                             )
                                            ((EQ (CAR PLACE)
                                                 'Near%:)
                                             (SETQ NEAR (CADR PLACE))
                                             (COND
                                                ([SOME FILELST (FUNCTION (LAMBDA (FL)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           FL))
                                                                            NAME TYPE NEAR LISTNAME]
                                                 (PRINT (LIST 'on FILE)
                                                        T T))
                                                (T (PRINT (LIST (CADR PLACE)
                                                                'not
                                                                'found)
                                                          T T)
                                                   (ERROR!)))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE)))
                                            ([OR [UNDONLSETQ (PROGN (SAVESET
                                                                     (SETQ LISTNAME (CAR PLACE))
                                                                     (MERGEINSERT
                                                                      NAME
                                                                      (LISTP (GETTOPVAL LISTNAME))
                                                                      T)
                                                                     T
                                                                     'NOPRINT)
                                                                    (OR (SETQ FILE
                                                                         (CAR (WHEREIS NAME TYPE
                                                                                     FILELST)))
                                                                        (ERROR!]
                                                 (SOME FILELST (FUNCTION (LAMBDA (X)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           X))
                                                                            NAME TYPE NEAR LISTNAME]
                                             (PRIN1 "  value is filed on " T)
                                             (PRINT FILE T T)
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                 (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed")

                                             )
                                            (T (PRIN1 "    put list " T)
                                               (PRIN2 (CAR PLACE)
                                                      T T)
                                               (SETQ FILE
                                                (WHATIS (ASKUSER NIL NIL " on file: "
                                                                   '(("" "" EXPLAINSTRING 
                                                                         "a file name" KEYLST ()))
                                                                   T)
                                                       'FILE))
                                               (SAVESET (CAR PLACE)
                                                      (MERGEINSERT NAME
                                                             (LISTP (GETTOPVAL (CAR PLACE)))
                                                             T)
                                                      T
                                                      'NOPRINT)

                                     (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.")

                                               (ADDNEWCOM (FILECOMS FILE)
                                                      NAME TYPE (CAR PLACE)
                                                      FILE)
                                               (for F in (fetch WHENFILED of TYPE)
                                                  do (for I in (GETTOPVAL (CAR PLACE))
                                                            do (APPLY* F I TYPE FILE]
                                         (AND FILE (ADDFILE FILE))
                                         (SETQ LASTFILE PLACE)))
                           (GO LP]
           (AND BUFS (BKBUFS BUFS))
           (UPDATEFILES])

(ADDTOFILE
  [LAMBDA (NAME TYPE FILE NEAR LISTNAME)                 (* lmm "21-Nov-84 11:43")
                                                             (* ; "adds NAME to the file FILE")
    (PROG (TEM COMSNAME)
          [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T)
                         (COND
                            ((FMEMB TYPE FILELST)
                             (GETFILEPKGTYPE (swap TYPE FILE)))
                            (T (GETFILEPKGTYPE TYPE]
          (SETQ FILE (WHATIS FILE 'FILE))
          (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                     NAME TYPE NEAR LISTNAME)
              (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
          (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))
          (AND FILE (NOT (FMEMB FILE FILELST))
               (ADDFILE FILE))
          (RETURN FILE])

(WHATIS
  [LAMBDA (USERINPUT ONLY)                               (* lmm "28-Nov-84 16:49")

    (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble;  if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable")

    (PROG (TEM UCASE)
          (RETURN (COND
                     ((NULL USERINPUT)                       (* ; "nowhere")
                      NIL)
                     [(LISTP USERINPUT)
                      (COND
                         (ONLY (ERROR!))
                         (T (SELECTQ (CAR USERINPUT)
                                ((@ Near%:) 
                                     (CONS 'Near%: (CDR USERINPUT)))
                                (WHATIS (CAR USERINPUT)
                                       'LIST]
                     ([AND (NEQ ONLY 'LIST)
                           (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT)))
                                      FILELST)
                               (LISTP (GETTOPVAL (FILECOMS UCASE)))
                               (SETQ TEM (FIXSPELL UCASE NIL FILELST T]
                      TEM)
                     ((AND (NEQ ONLY 'FILE)
                           (LISTP (GETTOPVAL USERINPUT)))
                      (LIST USERINPUT))
                     ((AND (NEQ ONLY 'LIST)
                           (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE)
                                      NIL T)
                               'Y))
                      UCASE)
                     ((AND (NEQ ONLY 'FILE)
                           (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT)
                                      NIL T)
                               'Y))
                      (LIST USERINPUT))
                     (T                                      (* ; "none of above")
                        (ERROR!])

(ADDTOCOMS
  [LAMBDA (COMS NAME TYPE NEAR LISTNAME)                 (* rmk%: "10-JUN-82 22:53")

    (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms);  return NIL if unsuccessful.  If LISTNAME is given, then only insert by adding to LISTNAME.  If NEAR is given, only insert near it")

    (COND
       ((NULL COMS)
        NIL)
       [(LITATOM COMS)                                       (* ; 
      "given a name of a command;  rebind COMSNAME to current variable and try to add to its value")
        (OR [PROG ((COMSNAME COMS))
                  (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME))
                                 NAME TYPE NEAR (AND (NEQ COMS LISTNAME)
                                                     LISTNAME]
            (AND (EQ COMS LISTNAME)
                 (ADDNEWCOM COMS NAME TYPE]
       (T (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (for TAIL on COMS do (COND
                                              [(LISTP (CAR TAIL))
                                               (COND
                                                  ((ADDTOCOM (CAR TAIL)
                                                          NAME TYPE NEAR LISTNAME)
                                                   (RETURN T]
                                              (T (SELECTQ (CAR TAIL)
                                                     ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                                                          (SETQ TAIL (CDR TAIL)))
                                                     NIL])

(ADDTOCOM
  [LAMBDA (COM NAME TYPE NEAR LISTNAME)                  (* ; "Edited  2-May-87 19:04 by Pavel")
                                                             (* ; 
                        "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful")
    (PROG (TEM)
          (COND
             ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM]
              (RETURN)))
          [COND
             ((SETQ TEM (fetch ADD of (CAR COM)))
              (RETURN (COND
                         ((OR (NULL LISTNAME)
                              (INFILECOMS? LISTNAME 'FILEVARS (LIST COM)))
                          (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR))
                               (MARKASCHANGED COMSNAME 'VARS))
                          TEM]
          (RETURN
           (SELECTQ (CAR COM)
               (FNS (AND (EQ TYPE 'FNS)
                         (ADDTOCOM1 COM NAME NEAR LISTNAME)))
               ((VARS INITVARS) 
                    (COND
                       ((OR (EQ (CAR COM)
                                'VARS)
                            NEAR LISTNAME)                   (* ; 
                                  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.")
                        (SELECTQ TYPE
                            (EXPRESSIONS (COND
                                            ((EQ (CAR NAME)
                                                 'SETQ)
                                             (ADDTOCOM1 COM (CDR NAME)
                                                    NEAR LISTNAME))))
                            (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME))
                            NIL))))
               (COMS (ADDTOCOMS (COND
                                       [(EQ (CADR COM)
                                            '*)
                                        (COND
                                           ((LITATOM (CADDR COM))
                                            (CADDR COM))
                                           (T (RETURN]
                                       (T (CDR COM)))
                            NAME TYPE NEAR LISTNAME))
               (DECLARE%: (AND (OR LISTNAME NEAR)
                               (ADDTOCOMS (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     ((LITATOM (CADDR COM))
                                                      (CADDR COM))
                                                     (T (RETURN]
                                                 (T (CDR COM)))
                                      NAME TYPE NEAR LISTNAME)))
               (CL:EVAL-WHEN (AND (OR LISTNAME NEAR)
                                  (ADDTOCOMS (COND
                                                    [(EQ (CL:THIRD COM)
                                                         '*)
                                                     (COND
                                                        ((LITATOM (CL:FOURTH COM))
                                                         (CL:FOURTH COM))
                                                        (T (RETURN]
                                                    (T (CDDR COM)))
                                         NAME TYPE NEAR LISTNAME)))
               ((PROP IFPROP) 
                    (SELECTQ TYPE
                        (PROPS (COND
                                  ((EQ (CADR COM)
                                       (CADR NAME))
                                   (ADDTOCOM1 (CDR COM)
                                          (CAR NAME)
                                          NEAR LISTNAME))
                                  ((AND (EQ (CAR NAME)
                                            (CADDR COM))
                                        (NULL (CDDDR COM)))
                                   [/RPLACA (CDR COM)
                                          (UNION (MKLIST (CDR NAME))
                                                 (MKLIST (CADR COM]
                                   (MARKASCHANGED COMSNAME 'VARS)
                                   T)))
                        (MACROS (COND
                                   ([AND (for PROP inside (CADR COM)
                                            always (EQMEMB PROP MACROPROPS))
                                         (for PROP in MACROPROPS
                                            always (OR (EQMEMB PROP (CADR COM))
                                                           (NOT (GETPROP NAME PROP]

                                    (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")

                                    (ADDTOCOM1 (CDR COM)
                                           NAME NEAR LISTNAME))))
                        NIL))
               ((PROPS ALISTS) 
                    (AND (EQ TYPE (CAR COM))
                         (ADDTOCOM1
                          COM
                          (/NCONC1 (OR [ASSOC (CAR NAME)
                                              (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     [(LITATOM (CADDR COM))
                                                      (AND (OR (NULL LISTNAME)
                                                               (EQ (CADDR COM)
                                                                   LISTNAME))
                                                           (GETTOPVAL (CADDR COM]
                                                     (T (RETURN]
                                                 (T (CDR COM]
                                       (LIST (CAR NAME)))
                                 (CADR NAME))
                          NEAR LISTNAME)))
               (P (COND
                     ((AND (EQ TYPE 'EXPRESSIONS)
                           (NEQ (CAR NAME)
                                'SETQ))
                      (ADDTOCOM1 COM NAME NEAR LISTNAME))))
               (AND (EQ (CAR COM)
                        TYPE)
                    (ADDTOCOM1 COM NAME NEAR LISTNAME])

(ADDTOCOM1
  [LAMBDA (COM NAME NEAR LISTNAME)                       (* rmk%: " 3-JAN-82 22:53")
    (COND
       [(EQ (CADR COM)
            '*)                                              (* ; "add to list name")
        (AND [COND
                (LISTNAME (EQ (CADDR COM)
                              LISTNAME))
                (T (LITATOM (CADDR COM]
             (SAVESET (CADDR COM)
                    [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM]
                           (COND
                              ((AND NEAR (SETQ NEAR (MEMBER NEAR COM)))
                               (/RPLACD NEAR (CONS NAME (CDR NEAR)))
                               COM)
                              (T (MERGEINSERT NAME COM T]
                    T
                    'NOPRINT]
       ((NULL LISTNAME)                                      (* ; "add to standard com")
        [AND (NOT (MEMBER NAME (CDR COM)))
             (COND
                [(SETQ NEAR (MEMBER NEAR COM))
                 (/RPLACD NEAR (CONS NAME (CDR NEAR]
                (T (/RPLACD COM (MERGEINSERT NAME (CDR COM]
        (MARKASCHANGED COMSNAME 'VARS)
        T])

(ADDNEWCOM
  [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE)             (* rmk%: " 3-JAN-82 22:53")

    (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE.  --- if LISTNAME is given, then use it as the listname")

    (PROG (NEWCOM OLDCOM TAIL)
          (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE))
          [COND
             ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME)))
              (RETURN (SAVESET COMSNAME (LIST NEWCOM)
                             T
                             'NOPRINT]
      LP  [COND
             ((OR (NLISTP (SETQ OLDCOM (CAR TAIL)))
                  (SELECTQ (CAR OLDCOM)
                      ((LOCALVARS SPECVARS BLOCKS) 
                           T)
                      (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM)))
                      NIL))
              (/ATTACH NEWCOM TAIL))
             ((LISTP (CDR TAIL))
              (SETQ TAIL (CDR TAIL))
              (GO LP))
             (T (/RPLACD TAIL (LIST NEWCOM]
          (MARKASCHANGED COMSNAME 'VARS])

(MAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* ; "Edited  8-Apr-87 14:55 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    (PROG (TEM)

     (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname")

          (AND (LISTP NAME)
               (SETQ NAME (COPY NAME)))
          (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE))
                           (APPLY* TEM NAME TYPE LISTNAME FILE))
                      (SELECTQ TYPE
                          (PROPS [AND (NULL LISTNAME)
                                      (CONS 'PROP (CONS (COND
                                                           ((AND (LISTP (CDR NAME))
                                                                 (NULL (CDDR NAME)))
                                                            (CADR NAME))
                                                           (T (CDR NAME)))
                                                        (OR (LISTP (CAR NAME))
                                                            (LIST (CAR NAME])
                          (EXPRESSIONS [COND
                                          ((EQ (CAR NAME)
                                               'SETQ)
                                           (MAKENEWCOM (CDR NAME)
                                                  'VARS LISTNAME FILE))
                                          (T (CONS 'P (COND
                                                         (LISTNAME (LIST '* LISTNAME))
                                                         (T (LIST NAME])
                          NIL)
                      (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE])

(DEFAULTMAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* lmm "20-OCT-82 22:48")
    (COND
       ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST)
                 (fetch MACRO of TYPE)
                 (fetch GETDEF of TYPE)))
        (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION
                                                                            of TYPE)
                                                                         TYPE)
               T))
       ((NULL DEFAULTCOMHASFILEFLG)                          (* ; "disable FOOFNS FOOVARS junk")
        (LIST TYPE NAME))
       ((EQ FILE T)                                          (* ; 
                                                           "FILE=T only when called from SHOWDEF")
        (LIST TYPE NAME))
       ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE))
                                      (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME))
                                             T)
                                      T
                                      'NOPRINT]              (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items")
        (LIST TYPE '* LISTNAME))
       (T (LIST TYPE NAME])
)

(RPAQ? DEFAULTCOMHASFILEFLG )

(ADDTOVAR MARKASCHANGEDFNS )
(DEFINEQ

(MERGEINSERT
  [LAMBDA (NEW LST ONEFLG)                               (* lmm "30-Jun-86 18:11")

    (* ;; "searches LST to find the most reasonable place to insert NEW.  Does nothing if ONEFLG is T and NEW is already a member of LST")

    (COND
       ((AND ONEFLG (MEMBER NEW LST))
        LST)
       ((LISTP NEW)
        (/NCONC1 LST NEW))
       (T (PROG ((N 0)
                 LST1 PLACE TEM)
                (SETQ LST1 LST)
            LP  

           (* ;; "finds the function with the longest leading common substring.  The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.")

                (COND
                   ((NULL LST1)
                    (GO OUT))
                   ((OR (LISTP (CAR LST1))
                        (SETQ TEM (STRPOS (CAR LST1)
                                         NEW 1 NIL T T)))

                    (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE")

                    (SETQ PLACE LST1)
                    (GO OUT))
                   ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1)
                                                NEW))
                           N)
                    (SETQ N TEM)
                    (SETQ PLACE LST1)))
                (SETQ LST1 (CDR LST1))
                (GO LP)
            OUT (SETQ TEM (CAR PLACE))
                (OR [SOME (OR PLACE LST)
                          (FUNCTION (LAMBDA (X LST)
                                      (COND
                                         ([OR (ALPHORDER NEW X)
                                              (AND PLACE (NOT (ALPHORDER TEM X]

                                 (* ;; "for example, if the FNS list is something like (...  FOO FOO1 ...) where the ...  may or may not be in order, e.g.  (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.")

                                          (/ATTACH NEW LST))
                                         (T (SETQ TEM X)
                                            NIL]
                    (SETQ LST (/NCONC1 LST NEW)))
                (RETURN LST])

(MERGEINSERT1
  [LAMBDA (X Y)                                          (* rmk%: "24-MAY-82 00:05")

    (* ;; "value is the number of leading characters of X and Y that agree.")

    (PROG ((N 1)
           C1 C2)
      LP  [COND
             ((OR (NULL (SETQ C1 (NTHCHARCODE X N)))
                  (NULL (SETQ C2 (NTHCHARCODE Y N)))
                  (NEQ C1 C2))
              (RETURN (SUB1 N]
          (SETQ N (ADD1 N))
          (GO LP])
)

(RPAQ? ADDTOFILEKEYLST [LIST '(%[ "" EXPLAINSTRING 
                                      "[ -- prettyprint the item to terminal and then ask again" 
                                      NOECHOFLG T)
                                 '(= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T)
                                 (LIST (CHARACTER (CHARCODE ^J))
                                       ""
                                       'EXPLAINSTRING "{line-feed} - same as previous response"
                                       'NOECHOFLG T)
                                 '(%  " %
-" EXPLAINSTRING "{space} - no action" NOECHOFLG T)
                                 '(%] "Nowhere%
-" EXPLAINSTRING 
                                      "] - nowhere, item is marked as a dummy%
-" NOECHOFLG T)
                                 '[%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
                                      (( "" CONFIRMFLG (%) %] %  %
-)
                                          RETURN
                                          (CDR ANSWER]
                                 '(@ "Near: " EXPLAINSTRING 
                                     "@ other-item   -- put the item near the other item" NOECHOFLG T
                                     KEYLST (( "" CONFIRMFLG (%
-)
                                                RETURN ANSWER)))
                                 (LIST (CHARACTER (CHARCODE ^M))
                                       ""
                                       'RETURN
                                       '% )
                                 '("" "File name: " EXPLAINSTRING "a file name" KEYLST (])

(RPAQ? LASTFILE )



(* ;; "deleting an item from a file")

(DEFINEQ

(DELFROMFILES
  [LAMBDA (NAME TYPE FILES)                              (* rmk%: " 6-MAR-82 13:16")

    (* ;; "Eliminates NAME as an item of type TYPE in COMS.")

    (PROG (COMS)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (RETURN (for FILE inside (OR FILES FILELST)
                     when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE))
                                            NAME TYPE)
                                  (COND
                                     ((INFILECOMS? NAME TYPE COMS)
                                      (printout T "(could not delete " NAME " from " FILE ")" T))))
                     collect (for FN in (fetch WHENUNFILED of TYPE)
                                    do (APPLY* FN NAME TYPE FILE))
                           FILE])

(DELFROMCOMS
  [LAMBDA (COMS NAME TYPE)                               (* bvm%: " 1-Oct-86 22:02")

    (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list).  Returns T if it does anything")

    (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.")

    (COND
       [(LITATOM COMS)
        (LET ((COMSNAME COMS))
             (DECLARE (SPECVARS COMS))
             (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME)))
                  (DELFROMCOMS COMS NAME TYPE]
       (T (PROG (DONE)
                (SETQ TYPE (GETFILEPKGTYPE TYPE))
            LP  (COND
                   ((NLISTP COMS)
                    (RETURN DONE)))
                [COND
                   ((LISTP (CAR COMS))
                    (SELECTQ (DELFROMCOM (CAR COMS)
                                    NAME TYPE)
                        (ALL (/RPLNODE2 COMS (CDR COMS))
                             (SETQQ DONE ALL)
                             (GO LP))
                        (NIL)
                        (SETQ DONE T)))
                   (T (SELECTQ (CAR COMS)
                          ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                               (SETQ COMS (CDR COMS)))
                          (COND
                             ((AND (EQ TYPE 'VARS)
                                   (EQ NAME (CAR COMS)))
                              (/RPLNODE2 COMS (CDR COMS))
                              (SETQ DONE T)
                              (GO LP]
                (SETQ COMS (CDR COMS))
                (GO LP])

(DELFROMCOM
  [LAMBDA (COM NAME TYPE)                                (* ; "Edited  2-May-87 19:02 by Pavel")
                                                             (* ; "Tries to delete NAME from COM")
    (PROG (TEM VAR NEW)
          (COND
             ((SETQ TEM (fetch DELETE of (CAR COM)))
              (AND (SETQ TEM (APPLY* TEM COM NAME TYPE))
                   (MARKASCHANGED COMSNAME 'VARS))
              (RETURN TEM)))
          (RETURN (SELECTQ (CAR COM)
                      ((DECLARE%: COMS) 
                           (DELFROMCOMS (COND
                                               [(EQ (CADR COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CADDR COM))
                                                    (CADDR COM))
                                                   (T (RETURN]
                                               (T (CDR COM)))
                                  NAME TYPE))
                      ((CL:EVAL-WHEN) 
                           (DELFROMCOMS (COND
                                               [(EQ (CL:THIRD COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CL:FOURTH COM))
                                                    (CL:FOURTH COM))
                                                   (T (RETURN]
                                               (T (CDDR COM)))
                                  NAME TYPE))
                      ((ALISTS PROPS) 
                           (AND (EQ TYPE (CAR COM))
                                (COND
                                   ((EQ (CADR COM)
                                        '*)
                                    (COND
                                       ([AND (LITATOM (SETQ VAR (CADDR COM)))
                                             (SETQ TEM (ASSOC (CAR NAME)
                                                              (GETTOPVAL VAR)))
                                             (NEQ (CDR TEM)
                                                  (SETQ TEM (REMOVEITEM (CADR NAME)
                                                                   (CDR TEM]
                                        (SAVESET VAR TEM T 'NOPRINT)
                                        T)))
                                   ([AND [CDR (SETQ TEM (ASSOC (CAR NAME)
                                                               (CDR COM]
                                         (NEQ (CDR TEM)
                                              (SETQ NEW (REMOVEITEM (CADR NAME)
                                                               (CDR TEM]
                                    (/RPLACD TEM NEW)
                                    (MARKASCHANGED COMSNAME 'VARS)
                                    T))))
                      (BLOCKS 
                              (* ;; "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")

                              [AND (EQ TYPE 'FNS)
                                   (for BLOCK in (INFILECOMTAIL COM T)
                                      do (AND (MEMB NAME BLOCK)
                                                  (/DREMOVE NAME BLOCK))
                                            (for X in BLOCK
                                               when (AND (LISTP X)
                                                             (MEMB NAME (CDR X)))
                                               do (/RPLACD X (REMOVE NAME (CDR X])
                      ((PROP IFPROP) 
                           [SELECTQ TYPE
                               (PROPS (RETURN (COND
                                                 ((EQ (CADR COM)
                                                      (CADR NAME))
                                                  (DELFROMCOM1 (CDR COM)
                                                         (CAR NAME)))
                                                 ((AND (EQMEMB (CADR NAME)
                                                              (CADR COM))
                                                       [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM]
                                                       (EQ (CAR TEM)
                                                           (CAR NAME)))
                                                  [/RPLACA (CDR COM)
                                                         (REMOVE (CADR NAME)
                                                                (MKLIST (CADR COM]
                                                  (MARKASCHANGED COMSNAME 'VARS)
                                                  T))))
                               (COND
                                  ([for PROP inside (CADR COM)
                                      always (EQ TYPE (GETPROP PROP 'PROPTYPE]
                                   (DELFROMCOM1 (CDR COM)
                                          NAME])
                      ((RECORDS INITRECORDS SYSRECORDS) 
                           (AND (EQ TYPE 'RECORDS)
                                (DELFROMCOM1 COM NAME)))
                      (P (AND (EQ TYPE 'EXPRESSIONS)
                              (DELFROMCOM1 COM NAME)))
                      ((VARS INITVARS) 
                           (AND (EQ TYPE 'VARS)
                                (DELFROMCOM1 COM NAME T)))
                      (AND (EQ TYPE (CAR COM))
                           (DELFROMCOM1 COM NAME])

(DELFROMCOM1
  [LAMBDA (COM NAME FLG)                                 (* rmk%: "10-JUN-82 22:44")

    (* ;; 
  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed")

    (LET (TEM VAL)
         (COND
            ((EQ (CADR COM)
                 '*)
             (COND
                ([AND (LITATOM (SETQ TEM (CADDR COM)))
                      (NEQ (SETQ VAL (GETTOPVAL TEM))
                           (SETQ VAL (REMOVEITEM NAME VAL FLG]
                 (SAVESET TEM VAL T 'NOPRINT)
                 T)))
            ((NEQ (CDR COM)
                  (SETQ TEM (REMOVEITEM NAME (CDR COM)
                                   FLG)))
             (/RPLACD COM TEM)
             (MARKASCHANGED COMSNAME 'VARS)
             T])

(REMOVEITEM
  [LAMBDA (X LST FLG)                                    (* ; "Edited 25-May-88 17:52 by drc:")
                                                             (* lmm "10-FEB-78 17:29")

    (* ;; 
  "returns a subset of LST with X deleted;  if FLG is set, also remove elements whose CAR is X")

    (COND
       [[OR (MEMBER X LST)
            (AND FLG (SOME LST (FUNCTION (LAMBDA (Y)
                                           (EQUAL (CAR (LISTP Y))
                                                  X]
        (SUBSET LST (FUNCTION (LAMBDA (Y)
                                (AND (NOT (EQUAL Y X))
                                     (OR (NOT FLG)
                                         (NLISTP Y)
                                         (NOT (EQUAL (CAR Y)
                                                     X]
       (T LST])

(MOVETOFILE
  [LAMBDA (TOFILE NAME TYPE FROMFILE)                    (* rmk%: "18-OCT-79 19:51")
                                                             (* ; "To move items between files")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    [COND
       ((OR (EQ TYPE 'FNS)
            FROMFILE)                                        (* ; 
       "FNS definition can reside on file if LOADFNS was done.  This guarantees that it is loaded.")
        (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM]
    (AND (EQ TYPE 'FNS)
         (MARKASCHANGED NAME TYPE))                      (* ; 
                                                   "FNS won't get dumped unless they are `changed'")
    (DELFROMFILES NAME TYPE FROMFILE)
    (ADDTOFILE NAME TYPE TOFILE])
)

(MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)

(MOVD? 'MOVETOFILE 'MOVEITEM NIL T)

(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)



(* ; "functions for doing things and marking them changed and auxiliary functions")

(DEFINEQ

(SAVEPUT
  [LAMBDA (ATM PROP VAL)                                 (* lmm " 7-May-84 16:56")

    (* ;; "analogous to SAVESET but also marks changed property lists;  LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT")

    [COND
       ((NOT (LITATOM ATM))
        (ERRORX (LIST 14 ATM]
    (PROG ((X (GETPROPLIST ATM))
           X0 TEM OLDFLG)
      LOOP
          (COND
             ((NLISTP X)
              (COND
                 ((AND (NULL X)
                       X0)                                   (* ; 
                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")
                  (SETQ TEM (LIST PROP VAL))
                  (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                        LISPXHIST))
                  (FRPLACD (CDR X0)
                         TEM)
                  (GO RET)))

              (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")

              )
             ((NLISTP (CDR X))

              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning.")

              )
             [(EQ (CAR X)
                  PROP)
              (SETQ OLDFLG (NEQ (EQUALN (CADR X)
                                       VAL 400)
                                T))                          (* ; "i.e. it probably changed")
              (/RPLACA (CDR X)
                     VAL)
              (COND
                 ((NOT OLDFLG)
                  (GO RET1))
                 (T (OR (EQ DFNFLG T)
                        (LISPXPRINT (LIST 'new PROP 'property 'for ATM)
                               T T))
                    (GO RET]
             (T (SETQ X (CDDR (SETQ X0 X)))
                (GO LOOP)))
          [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM]
          (SETPROPLIST ATM TEM)
          (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                LISPXHIST))
      RET (MARKASCHANGED (LIST ATM PROP)
                 'PROPS
                 (NOT OLDFLG))
      RET1
          (AND ADDSPELLFLG (ADDSPELL ATM 0))
          (RETURN VAL])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
    (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT))
)
(DEFINEQ

(UNMARKASCHANGED
  [LAMBDA (NAME TYPE)                                    (* JonL "24-Jul-84 19:59")

    (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties.  Value is name if anything is done")

    (PROG (ANYFLG)
          (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE
                                                                          TYPE
                                                                          'TYPE]
             while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL)
                                                               (SETQ ANYFLG T))
          [for F TAIL PROP TYPEDPROP in FILELST
             when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP
                                                    (ASSOC TYPE (fetch TOBEDUMPED
                                                                   of (SETQ PROP
                                                                           (fetch FILEPROP
                                                                              of F]
             do (SETQ ANYFLG T)
                   (COND
                      ((SETQ TAIL (REMOVE (CAR TAIL)
                                         (CDR TYPEDPROP)))
                       (/RPLACD TYPEDPROP TAIL))
                      (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP
                                                                              (fetch TOBEDUMPED
                                                                                 of PROP]
          (RETURN (AND ANYFLG NAME])

(PREEDITFN
  [LAMBDA (ATM TYPE EDITCHANGES)                         (* rmk%: "18-FEB-82 21:49")
                                                             (* ; 
                                           "EDITL is advised to call this before editing something")
    (AND FILEPKGFLG (SELECTQ TYPE
                        (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                   (CONS))
                                                            CLISPARRAY))
                                      (for X in (GETPROPLIST ATM)
                                         do (OR (NLISTP X)
                                                    (GETHASH X CLISPARRAY)
                                                    (PUTHASH X (CONS (CAR X)
                                                                     (CDR X))
                                                           CLISPARRAY]

                                 (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made")

                                 [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS)
                                                      EDITCHANGES
                                                      (APPEND (GETPROPLIST ATM])
                        (VARS [COND
                                 ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE))
                                  [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                    (CONS))
                                                             CLISPARRAY))
                                       (for X in (EVALV ATM)
                                          do (OR (NLISTP X)
                                                     (GETHASH X CLISPARRAY)
                                                     (PUTHASH X (CONS (CAR X)
                                                                      (CDR X))
                                                            CLISPARRAY]
                                  (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS)
                                                       EDITCHANGES
                                                       (for X in (EVALV ATM)
                                                          collect (CAR X])
                        NIL])

(POSTEDITPROPS
  [LAMBDA (EDITCHANGES OLDPROPS)                         (* rmk%: "18-FEB-82 21:50")
                                                             (* ; "was RESETSAVE'd from PREEDITFN")
    (PROG (OV FOUNDCHANGE)
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP)
                 when (for OLDPROP on OLDPROPS by (CDDR OLDPROP)
                             do (COND
                                       ((EQ (CAR OLDPROP)
                                            (CAR NEWPROP))   (* ; "Found the property")
                                        [AND (EQ (CADR OLDPROP)
                                                 (CADR NEWPROP))
                                             (COND
                                                ((NLISTP (CADR OLDPROP))
                                                             (* ; "value is same")
                                                 (RETURN))
                                                ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP)
                                                                                 CLISPARRAY))
                                                      (EQ (CAADR NEWPROP)
                                                          (CAR OV))
                                                      (EQ (CDADR NEWPROP)
                                                          (CDR OV)))
                                                 (PUTHASH (CADR NEWPROP)
                                                        NIL CLISPARRAY)
                                                             (* ; 
                                         "value has been edited (CLISPARRAY translation went away)")
                                                 (RETURN]
                                        (RETURN T))) finally 
                                                             (* ; "didn't find the property")
                                                           (RETURN T))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 (CAR NEWPROP))
                               'PROPS NIL)
                       (SETQ FOUNDCHANGE T))
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])

(POSTEDITALISTS
  [LAMBDA (EDITCHANGES OLDTOKENS)                        (* rmk%: " 4-JAN-82 10:14")
    (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES]
                                                             (* ; 
                                                           "called after an ALIST has been edited")
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 X)
                               'ALISTS NIL)
                       (SETQ FOUNDCHANGE T))
              [for NEWENTRY in NEWENTRIES
                 do (COND
                           ([AND (LISTP NEWENTRY)
                                 (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY))
                                           (EQ (CAR NEWENTRY)
                                               (CAR OV))
                                           (EQ (CDR NEWENTRY)
                                               (CDR OV]
                            (PUTHASH NEWENTRY NIL CLISPARRAY)
                            (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                     (CAR NEWENTRY))
                                   'ALISTS NIL)
                            (SETQ FOUNDCHANGE T]
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])
)

(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
                       (PUTPROP . SAVEPUT))



(* ; "sub-functions for file package commands & types")

(DEFINEQ

(ALISTS.GETDEF
  [LAMBDA (NAME TYPE OPTIONS)                            (* Pavel " 7-Oct-86 17:24")
    (AND (LISTP NAME)
         (CL:SYMBOLP (CAR NAME))
         (LET [(ASSOCIATION (ASSOC (CADR NAME)
                                   (GETTOPVAL (CAR NAME]
              (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME)
                                     ASSOCIATION])

(ALISTS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm "16-OCT-78 20:02")
                                                             (* ; 
                                          "called by MARKASCHANGED when an ALIST entry has changed")
    (PROG [(VARTYPE (GETPROP (CAR NAME)
                           'VARTYPE]
          (AND (LISTP VARTYPE)
               (EQ (CAR VARTYPE)
                   'ALIST)
               (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME)
                                              (CADR VARTYPE)
                                              NEWFLG])

(CLEARCLISPARRAY
  [LAMBDA (NAME TYPE REASON)
    (DECLARE (SPECVARS NAME TYPE REASON))            (* lmm "14-Aug-84 15:03")
    (AND CLISPARRAY (MAPHASH CLISPARRAY (COND
                                           [(EQ TYPE 'I.S.OPRS)
                                            (FUNCTION (LAMBDA (TRAN FORM)
                                                        (AND (MEMB NAME FORM)
                                                             (PUTHASH FORM NIL CLISPARRAY]
                                           (T                (* ; "MACRO changed")
                                              (FUNCTION (LAMBDA (TRAN FORM)
                                                          (COND
                                                             ((OR (EQ NAME (CAR FORM))
                                                                  (EQ (CAR (GETPROP (CAR FORM)
                                                                                  'CLISPWORD))
                                                                      'CHANGETRAN))
                                                              (PUTHASH FORM NIL CLISPARRAY])

(EXPRESSIONS.WHENCHANGED
  [LAMBDA (EXPR)                                         (* ; "Edited  6-Apr-87 20:21 by Pavel")
    (SELECTQ (CAR EXPR)
        ((SETQ SETQQ) 
             (UNMARKASCHANGED (CADR EXPR)
                    'VARS))
        ((PROGN PROG) 
             (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X)))
        NIL])

(MAKEALISTCOMS
  [NLAMBDA X                                             (* rmk%: "14-OCT-83 13:34")

    (* ;; "make command to dump prettydefmacros")

    (LIST
     (CONS 'ADDVARS
           (for PR in X
              join (for ALISTNAME inside (CAR PR)
                          collect (CONS ALISTNAME
                                            (for ATNAME inside (CDR PR) bind ENTRY
                                               when (SETQ ENTRY
                                                         (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME))
                                                             (PROGN (LISPXPRINT (LIST 'no ATNAME
                                                                                      'entry
                                                                                      'on ALISTNAME)
                                                                           T T)
                                                                    NIL))) collect ENTRY])

(MAKEFILESCOMS
  [NLAMBDA FILES                                         (* JonL "12-FEB-83 19:02")

    (* ;; "This scans the command just to warn the user about any errors.  Must match up with the big SELECTQ in FILESLOAD NIL")

    [for FILE in FILES
       do
       (OR
        (LITATOM FILE)
        (while (LISTP FILE)
           do (SELECTQ (CAR (OR (LISTP FILE)
                                    (RETURN)))
                      ((LOADCOMP LOADFROM))
                      (FROM (pop FILE)
                            (if (OR (EQ (CAR FILE)
                                            'VALUEOF)
                                        (if (AND (EQ (CAR FILE)
                                                         'VALUE)
                                                     (EQ (CADR FILE)
                                                         'OF))
                                            then (pop FILE)))
                                then (pop FILE)))
                      ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR))
                      (OR (FMEMB (CAR FILE)
                                 LOADOPTIONS)
                          (PRINT (CONS (CAR FILE)
                                       '(-- unrecognized FILES option))
                                 T)))
                 (pop FILE]
    (CONS 'FILESLOAD FILES])

(MAKELISPXMACROSCOMS
  [NLAMBDA X                                             (* lmm " 5-SEP-78 23:15")
    (PROG (TEM TEM2)
          (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                   LISPXHISTORYMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXHISTORYMACROS TEM)))
                                                       (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                          LISPXMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXMACROS TEM]
                        (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z LISPXCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2]
                                          (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z HISTORYCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2])

(MAKEPROPSCOMS
  [NLAMBDA X                                             (* lmm "26-FEB-78 17:10")

    (* ;; "make command to dump PROPS")

    (for PAIR in X collect (CONS 'PROP (CONS (COND
                                                            ((AND (LISTP (CDR PAIR))
                                                                  (NULL (CDDR PAIR)))
                                                             (CADR PAIR))
                                                            (T (CDR PAIR)))
                                                         (OR (LISTP (CAR PAIR))
                                                             (LIST (CAR PAIR])

(MAKEUSERMACROSCOMS
  [NLAMBDA X                                             (* rmk%: " 3-JAN-82 23:20")
    (PROG (TEM)
          [COND
             [X (for Y in X
                   do (OR (FASSOC Y USERMACROS)
                              (FASSOC Y EDITMACROS)
                              (LISPXPRINT (CONS Y '(-- no entry on USERMACROS))
                                     T T]
             (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR))
                               X]
          (RETURN (LIST (CONS 'ADDVARS
                              (NCONC (for VAR in '(USERMACROS EDITMACROS)
                                        when (SETQ TEM (for Y in (GETTOPVAL VAR)
                                                              when (FMEMB (CAR Y)
                                                                              X) collect Y))
                                        collect (CONS VAR TEM))
                                     (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS 
                                                                 DONTSAVEHISTORYCOMS)
                                        when [SETQ TEM
                                                  (SUBSET (GETTOPVAL LST)
                                                         (FUNCTION (LAMBDA (Y)
                                                                     (OR (FMEMB Y X)
                                                                         (AND (LISTP Y)
                                                                              (FMEMB (CAR Y)
                                                                                     X]
                                        collect (CONS LST TEM])

(PROPS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm " 7-SEP-78 22:08")
    (PROG [(PROPTYPE (GETPROP (CADR NAME)
                            'PROPTYPE]
          (COND
             [PROPTYPE (RETFROM 'MARKASCHANGED (COND
                                                  ((NEQ PROPTYPE 'IGNORE)
                                                   (MARKASCHANGED (CAR NAME)
                                                          PROPTYPE NEWFLG]
             (T (SELECTQ (CADR NAME)
                    (CLISPWORD (CLEARCLISPARRAY (CAR NAME)))
                    NIL])

(FILEGETDEF.LISPXMACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:12")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (EQ FIRST 'ADDTOVAR)
                                                                   (MEMB SECOND '(LISPXMACROS 
                                                                                        LISPXCOMS))
                                                                   T]
                when (SELECTQ (CADR X)
                             (LISPXMACROS                    (* ; 
                      "Rebuild the expressions cause there might be other elements in the ADDTOVAR")
                                          (AND (SETQ X (ASSOC NAME (CDDR X)))
                                               (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X))))
                             (LISPXCOMS [COND
                                           ((MEMB NAME (CDDR X))
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME)))
                                           ((SETQ X (ASSOC NAME (CDDR X)))
                                                             (* ; "For synonym pairs")
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X])
                             NIL) collect X])

(FILEGETDEF.ALISTS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'ADDTOVAR)
                                                          (EQ SECOND (CAR NAME]
       when (SETQ X (ASSOC (CADR NAME)
                               (CDDR X))) collect X
       finally (RETURN (COND
                              ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.RECORDS
  [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND)            (* lmm "26-Jun-86 15:56")
    (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                              (AND (MEMB FIRST CLISPRECORDTYPES)
                                                   (OR (EQ SECOND NAME)
                                                       (AND (MEMB SECOND '(%( %[))
                                                            (PROGN (RATOM)
                                                                   (RATOM)
                                                                   (RATOM)
                                                                   (EQ NAME (RATOM]
         (if (EQ (CAAR VAL)
                     'NOT-FOUND%:)
             then NOTFOUND
           elseif (CDR VAL)
             then (CONS 'PROGN VAL)
           else (CAR VAL])

(FILEGETDEF.PROPS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'PUTPROPS)
                                                          (EQ SECOND (CAR NAME]
       join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL)
                                                                              (CADR NAME))
                   join (LIST (CAR TAIL)
                                  (CADR TAIL)))
       finally (RETURN (COND
                              ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.MACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "28-May-86 09:51")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (FMEMB FIRST '(PUTPROPS DEFMACRO))
                                                                   (EQ SECOND NAME]
                join (if (EQ (CAR X)
                                     'DEFMACRO)
                             then (LIST X)
                           else (for TAIL on (CDDR X) by (CDDR TAIL)
                                       when (FMEMB (CAR TAIL)
                                                       MACROPROPS) collect (LIST 'PUTPROPS
                                                                                     (CADR X)
                                                                                     (CAR TAIL)
                                                                                     (CADR TAIL])

(FILEGETDEF.VARS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:14")
    (for X in (LOADFNS NIL SOURCE 'GETDEF NAME)
       do (SELECTQ (CAR X)
                  ((RPAQQ SETQQ) 
                       (RETURN (CADDR X)))
                  ((RPAQ SETQ RPAQ?) 
                       (RETURN (EVAL (CADDR X))))
                  NIL) finally (RETURN 'NOBIND])

(FILEGETDEF.FNS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: "29-Aug-86 22:30")
    (LET (MAP ENV)
         (COND
            [(AND (EQMEMB 'FAST OPTIONS)
                  (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
                                (GET-ENVIRONMENT-AND-FILEMAP SOURCE))
                         MAP))
             (for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME
                                                                                      (CDDR PAIR]
                do [OR (OPENP SOURCE)
                           (RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
                                                                             'OLD]
                      (SETFILEPTR SOURCE MAPLOC)
                      (RETURN (WITH-READER-ENVIRONMENT ENV
                                  [COND
                                     ((EQMEMB 'ARGLIST OPTIONS)
                                      (RATOM SOURCE)
                                      (READ SOURCE)
                                      (RATOM SOURCE)
                                      (LIST (READ SOURCE)
                                            (READ SOURCE)))
                                     (T (CADR (READ SOURCE])]
            (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])

(FILEPKGCOMS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 11:29")
    (PROG (COM TYP)
          [SELECTQ (CAR (LISTP DEFINITION))
              (COM (SETQ COM (CDR DEFINITION)))
              (TYPE (SETQ TYP (CDR DEFINITION)))
              (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION)))
                     (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION]

     (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE")

          (for I in COM by (CDDR I) do (SELECTQ I
                                                           ((ADD DELETE MACRO CONTENTS CONTAIN COM))
                                                           (ERROR I 
                                                                  "not file package command property"
                                                                  )))
                                                             (* ; 
                                                   "COM merely adds to spelling list, for builtins")
          [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS)
                                             (LISTGET COM 'CONTAIN]
                                                             (* ; "Until CONTAIN is de-documented.")
          (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP
                                                                         (LISTGET COM PROP)))
          [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS)
                                                           (SELECTQ I
                                                               ((DESCRIPTION TYPE))
                                                               (ERROR I 
                                                             "not file package type/command property"
                                                                      ]
                                                             (* ; 
                                                  "TYPE merely adds to spelling list, for builtins")
          (for PROP in (UNION '(DESCRIPTION TYPE)
                                      FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP
                                                                      (LISTGET TYP PROP])

(FILES.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 17:13")
    (PROGN (PUTDEF (FILECOMS NAME)
                  'VARS
                  (CAR DEFINITION)
                  REASON)                                    (* ; "DEFINE THE COMS")
           (ADDFILE NAME)                                (* ; 
                                                           "MAKE SURE IT IS A FILE PACKAGE ENTITY")
           [/replace TOBEDUMPED of (fetch FILEPROP of NAME)
                                          (FILEPKG.MERGECHANGES (CADR DEFINITION)
                                                 (fetch TOBEDUMPED of (fetch FILEPROP
                                                                                 of NAME]
           (OR (fetch FILEDATES of NAME)
               (/replace FILEDATES of NAME with (CADDR DEFINITION])

(VARS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "29-Jul-85 20:59")
    (/SETTOPVAL NAME DEFINITION T])

(FILES.WHENCHANGED
  [LAMBDA (NAME TYPE REASON)
    (MARKASCHANGED (FILECOMS NAME)
           'VARS REASON])
)

(ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO)

(ADDTOVAR SYSPROPS PROPTYPE)

(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)

(PUTPROPS SUBR PROPTYPE IGNORE)

(PUTPROPS LIST PROPTYPE IGNORE)

(PUTPROPS CODE PROPTYPE IGNORE)

(PUTPROPS FILEDATES PROPTYPE IGNORE)

(PUTPROPS FILE PROPTYPE IGNORE)

(PUTPROPS FILEMAP PROPTYPE IGNORE)

(PUTPROPS EXPR PROPTYPE FNS)

(PUTPROPS VALUE PROPTYPE VARS)

(PUTPROPS COPYRIGHT PROPTYPE FILES)

(PUTPROPS FILETYPE PROPTYPE FILES)

(PUTPROPS BAKTRACELST VARTYPE ALIST)

(PUTPROPS BREAKMACROS VARTYPE ALIST)

(PUTPROPS COMPILETYPELST VARTYPE ALIST)

(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))

(PUTPROPS ERRORTYPELST VARTYPE ALIST)

(PUTPROPS FONTDEFS VARTYPE ALIST)

(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))

(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)

(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)

(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)

(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))



(* ; "Define the commands below AFTER the various properties have been established.")


(ADDTOVAR USERMACROS (M NIL (MAKE FILE FILE))
                         (M (X . Y)
                            (E (MARKASCHANGED (COND ((LISTP 'X)
                                                     (CAR 'X))
                                                    (T 'X))
                                      'USERMACROS)
                               T)
                            (ORIGINAL (M X . Y))))

(ADDTOVAR EDITMACROS (M (X . Y)
                            (E (MARKASCHANGED (COND ((LISTP 'X)
                                                     (CAR 'X))
                                                    (T 'X))
                                      'USERMACROS)
                               T)
                            (ORIGINAL (M X . Y))))

(ADDTOVAR EDITCOMSA M)

(ADDTOVAR EDITCOMSL M)



(* ; "GETDEF methods")

(DEFINEQ

(RENAME
  [LAMBDA (OLD NEW TYPES FILES METHOD)               (* JonL "24-Jul-84 20:01")
    (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD)))

     (* ;; "special kludge: change the callers BEFORE if we are changing a field;  this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message")

          [for TYPE inside TYPES when (NEQ TYPE 'FIELDS)
             do (COPYDEF OLD NEW TYPE NIL (COND
                                                     ((EQ TYPE 'VARS)
                                                      'NOERROR]
          (CHANGECALLERS OLD NEW TYPES FILES METHOD)
          [for TYPE inside TYPES do (COND
                                                   ((AND (EQ TYPE 'FIELDS)
                                                         (HASDEF OLD 'FIELDS))

                                 (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file.  Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.")

                                                    (COPYDEF OLD NEW 'FIELDS))
                                                   (T (DELDEF OLD TYPE]
          (RETURN NEW])

(CHANGECALLERS
  [LAMBDA (OLD NEW AS-TYPES FILES METHOD)            (* ; "Edited  6-Dec-86 01:25 by lmm")
    (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES))
           REL TEM EDITCOMS FNS)
          (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD))
          [SETQ EDITCOMS
           (LIST (COND
                    [(OR (EQMEMB 'CAREFUL METHOD)
                         (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES))
                                (printout T "Warning --" OLD " is also defined as " TEM T)))

                     (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename.  Y means do it, No means skip, anything else goes into TTY.")

                     (SUBPAIR '(OLD NEW)
                            (LIST OLD NEW)
                            '(BIND (LPQ (F OLD N)
                                            (MARK %#1)
                                            (ORR (1 !0 P)
                                                 NIL)
                                            (MARK %#2)
                                            (COMS (SELECTQ (ASKUSER NIL NIL "   Replace ? "
                                                                  '((Y "Yes
")
                                                                    (N "No
")
                                                                    (%
 "")
                                                                    (%  "")
                                                                    (%
 "")
                                                                    (& ""))
                                                                  NIL NIL '(NOECHOFLG T))
                                                      (Y '(R1 OLD NEW))
                                                      (N NIL)
                                                      'TTY%:))
                                            (MARK %#3)
                                            (IF (EQ (%## (\ %#3))
                                                        (%## (\ %#2)))
                                                   ((\ %#1))
                                                   NIL]
                    (T (LIST 'R OLD NEW]
          (SELECTQ (COND
                      ((AND (EQMEMB 'MASTERSCOPE METHOD)
                            MSDATABASELST
                            (for TYPE inside AS-TYPES
                               do [COND
                                         ((SETQ TEM (SELECTQ TYPE
                                                        ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 
                                                             'CALL)
                                                        (MACROS '(CALL DIRECTLY))
                                                        ((VARS VARIABLES) 
                                                             '(USE OR BIND))
                                                        ((RECORDS FIELDS I.S.OPRS) 
                                                             (LIST 'USE 'AS TYPE))
                                                        (RETURN NIL)))
                                          (COND
                                             (REL (SETQ REL (LIST TEM 'OR REL)))
                                             (T (SETQ REL TEM] FINALLY (RETURN REL)))

                       (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known")

                       'MASTERSCOPE)
                      ((EQMEMB 'EDITCALLERS METHOD)
                       'EDITCALLERS)
                      (T 'SEARCH))
              (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND
                                                     ((NULL FILES)
                                                      (UPDATEFILES)
                                                      (FILEPKGCHANGES 'FNS]
                                                  (for FILE inside (OR FILES FILELST)
                                                     join (FILEFNSLST FILE]
                                 (FUNCTION UPDATEFN))
                           (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL))
                                                          T)
                                            FNS)))
              (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST)
                                          when (SETQ TEM (EDITCALLERS OLD X T))
                                          collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM)))
                                                             X))))
              (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST
                                                                                   X))))
              (ERROR "UNRECOGNIZED RENAME METHOD" METHOD))
          (AND (EQMEMB 'FNS AS-TYPES)
               (FMEMB OLD FNS)
               (SETQ FNS (REMOVE OLD FNS)))
          (EDITFROMFILE FNS FILES OLD EDITCOMS)
          [for TYPE inside AS-TYPES
             do (for FILE in (WHEREIS OLD TYPE FILES)
                       do (AND (ADDTOFILE NEW TYPE FILE)
                                   (DELFROMFILES OLD TYPE FILE)
                                   (printout T OLD " changed to " NEW " on " FILE)))
                   (COND
                      ((SETQ TEM (WHEREIS OLD TYPE FILES))
                       (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM]
          (COND
             (REL (UPDATECHANGED)
                  (COND
                     ((AND (SETQ TEM (GETRELATION OLD REL T))
                           (WHEREIS TEM 'FNS FILES))
                      (printout T "Couldn't find where " OLD " is referenced in " TEM T])
)
(DEFINEQ

(SHOWDEF
  [LAMBDA (NAME TYPE FILE)                              (* ; "Edited 16-Apr-2018 21:35 by rmk:")
                                                             (* ; 
                                                 "prettyprint NAME as it would be dumped as a TYPE")
    (RESETLST
        (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
              (DECLARE (SPECVARS . T))
              [AND FILE (NEQ FILE (OUTPUT))
                   (if (SETQ FL (OPENP FILE 'OUTPUT))
                       then (RESETSAVE (OUTPUT FL))
                     else (OUTFILE FILE)
                           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                                (OUTPUT]
              (PRETTYCOM (MAKENEWCOM NAME TYPE))))])

(COPYDEF
  [LAMBDA (OLD NEW TYPE SOURCE OPTIONS)              (* lmm "14-Aug-84 18:38")
                                                             (* ; "like MOVD, but takes a type.")
    (PROG (TEM DEF)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          [SETQ DEF (GETDEF OLD TYPE SOURCE (COND
                                                   ((EQ OPTIONS 'NOCOPY)
                                                    NIL)
                                                   (T (REMOVE 'NOCOPY (MKLIST OPTIONS]
                                                             (* ; 
      "The default is for GETDEF to return a COPY.  Make sure that NOCOPY isn't in options though.")
          (SELECTQ TYPE
              (VARS)
              (FILES [for X in (CAR DEF)
                        do                               (* ; 
                                          "change all the listnames which are of form filenameTYPE")
                              (SELECTQ (CAR X)
                                  ((PROP IFPROP) 
                                       (SETQ X (CDR X)))
                                  NIL)
                              (COND
                                 ((EQ (CADR X)
                                      '*)
                                  (SETQ X (CDDR X))
                                  (COND
                                     ((AND (LITATOM (CAR X))
                                           (SETQ TEM (STRPOS OLD (CAR X)
                                                            1 NIL T T)))
                                      (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X)
                                                                           TEM -1)))
                                             (COPY (GETTOPVAL (CAR X)))
                                             T)
                                      (FRPLACA X TEM])
              ((PROPS ALISTS) 
                   (OR (EQ (CAR NEW)
                           (CAR OLD))
                       (DSUBST (CAR NEW)
                              (CAR OLD)
                              DEF))
                   (OR (EQ (CADR NEW)
                           (CADR OLD))
                       (DSUBST (CADR NEW)
                              (CADR OLD)
                              DEF)))
              (DSUBST NEW OLD DEF))
          (PUTDEF NEW TYPE DEF)
          (RETURN NEW])

(GETDEF
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "13-Jul-85 04:10")

    (* ;; "returns the definition of NAME as a TYPE from SOURCE;  cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found.  The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.")

    (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS)))
          (DECLARE (SPECVARS NOCOPY))
          (SELECTQ OPTIONS
              (0 (SETQQ OPTIONS (NOERROR NODWIM))
                 (SETQ NOCOPY T))
              (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST))
                 (SETQ NOCOPY T))
              (T (SETQQ OPTIONS SPELL))
              NIL)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          (SELECTQ SOURCE
              (0 (SETQQ SOURCE CURRENT))
              (T (SETQQ SOURCE SAVED))
              (NIL (SETQQ SOURCE ?))
              NIL)
          [SELECTQ SOURCE
              (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS)))
              (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS]
                      (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS])
              (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS)))
              (COND
                 ((AND (LISTP SOURCE)
                       (EQ (CAR SOURCE)
                           '=))
                  (SETQ DEF (CDR SOURCE)))
                 (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS))
                    (SETQ NOCOPY T]
          (OR NOCOPY (SETQ DEF (COPY DEF)))
          (COND
             ((AND (EQ TYPE 'FNS)
                   (NOT (EQMEMB 'NODWIM OPTIONS)))
              (DWIMDEF DEF NAME SOURCE)))
          (RETURN DEF])

(GETDEFCOM
  [LAMBDA (X)                                            (* lmm " 4-Jul-85 13:31")

    (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in.  Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed.  --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.  That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.")
                                                             (* ; "a RETFROM point")
    (for Y in X join (GETDEFCOM0 Y])

(GETDEFCOM0
  [LAMBDA (COM)                                          (* wt%: " 7-FEB-79 23:28")
    (PROG (TEM)
          (RETURN (COND
                     ((SETQ TEM (fetch MACRO of (CAR COM)))
                                                             (* COND ((fetch CONTENTS of
                                                           (CAR COM)) (* ; 
                        "if it has a CONTENTS function, generally means it is not safe to evaluate")
                                                           (RETFROM (QUOTE GETDEFCOM))))
                      (for Y in (SUBPAIR (CAR TEM)
                                               (PRETTYCOM1 COM)
                                               (CDR TEM)) join (GETDEFCOM0 Y)))
                     (T (SELECTQ (CAR COM)
                            (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X)))
                            (ADDVARS (for Y in (PRETTYCOM1 COM)
                                        collect (CONS 'ADDTOVAR Y)))
                            (APPENDVARS (for Y in (PRETTYCOM1 COM)
                                           collect (CONS 'APPENDTOVAR Y)))
                            (P (APPEND (PRETTYCOM1 COM)))
                            (RETFROM 'GETDEFCOM])

(GETDEFCURRENT
  [LAMBDA (NAME TYPE OPTIONS)                            (* ; "Edited  2-May-87 19:00 by Pavel")
                                                             (* ; 
                                                           "Gets the current definition--source=0")
    (LET
     (DEF)
     (COND
        ((AND (SETQ DEF (fetch GETDEF of TYPE))
              (NEQ DEF T))

         (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")

         (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS))
                  (fetch NULLDEF of TYPE))
             (GETDEFERR NAME TYPE OPTIONS))
         DEF)
        (T
         (OR
          (NEQ
           [SETQ DEF
            (SELECTQ TYPE
                (FNS (AND (LITATOM NAME)
                          (EXPRP (SETQ DEF (VIRGINFN NAME)))
                          DEF))
                (VARS (if (LITATOM NAME)
                          then (GETTOPVAL NAME)
                        else 'NOBIND))
                ((FIELDS RECORDS) 
                     (if (LITATOM NAME)
                         then [SETQ DEF (SELECTQ TYPE
                                                (RECORDS (RECLOOK NAME))
                                                (MKPROGN (FIELDLOOK NAME]
                               (if (EQMEMB 'EDIT OPTIONS)
                                   then (COPY DEF)
                                 else DEF)))
                (FILES                                       (* ; 
              "what is the `definition' of a file?  -- I guess the COMS which say what it contains")
                       [if (LITATOM NAME)
                           then (if (SETQ DEF (GETFILEDEF NAME))
                                        then (UPDATEFILES)
                                              (LIST (LISTP (GETTOPVAL (FILECOMS DEF)))
                                                    (fetch TOBEDUMPED
                                                       of (fetch FILEPROP of DEF))
                                                    (LISTP (fetch FILEDATES of DEF])
                (TEMPLATES (if (AND (LITATOM NAME)
                                        (SETQ DEF (GETTEMPLATE NAME)))
                               then (LIST 'SETTEMPLATE (KWOTE NAME)
                                              (KWOTE DEF))))
                (MACROS [if [AND (LITATOM NAME)
                                     (SETQ DEF (for X on (GETPROPLIST NAME)
                                                  by (CDDR X) when (FMEMB (CAR X)
                                                                                  MACROPROPS)
                                                  join (LIST (CAR X)
                                                                 (CADR X]
                            then `(PUTPROPS ,NAME ,@DEF])
                (EXPRESSIONS (LISTP NAME))
                (PROPS [AND (LISTP NAME)
                            (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME))
                                                 [FUNCTION (LAMBDA (X)
                                                             (EQ X (CADR NAME]
                                                 (FUNCTION CDDR)))
                                 (LIST 'PUTPROPS (CAR NAME)
                                       (CADR NAME)
                                       (CADR DEF])
                (FILEPKGCOMS [AND (LITATOM NAME)
                                  (PROG ((COM (FILEPKGCOM NAME))
                                         (TYP (FILEPKGTYPE NAME)))
                                        (RETURN (COND
                                                   ((AND COM TYP)
                                                    (LIST (CONS 'COM COM)
                                                          (CONS 'TYPE TYP)))
                                                   (COM (LIST (CONS 'COM COM)))
                                                   (TYP (LIST (CONS 'TYPE TYP])
                (FILEVARS (COND
                             ((AND (LITATOM NAME)
                                   (LISTP (SETQ DEF (GETTOPVAL NAME)))
                                   (WHEREIS NAME 'FILEVARS))
                              DEF)
                             (T 'NOBIND)))
                (LET
                 ((COMS (LIST (MAKENEWCOM NAME TYPE)))
                  FILE)
                 [COND
                    ((NOT (SETQ DEF (GETDEFCOM COMS)))
                     (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
                         (RESETLST
                             (RESETSAVE PRETTYFLG)
                             (RESETSAVE FONTCHANGEFLG)
                             [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
                             (PRETTYDEFCOMS COMS)
                             (SETFILEPTR FILE 0)
                             [SETQ DEF
                              (for X in (READFILE FILE)
                                 join
                                 (SELECTQ (CAR X)
                                     ((*) 
                                          NIL)
                                     (DECLARE%: (for Y on (CDR X)
                                                   unless (SELECTQ (CAR Y)
                                                                  ((COPYWHEN EVAL@LOADWHEN 
                                                                          EVAL@COMPILEWHEN) 
                                                                       (RETURN (LIST Y)))
                                                                  (FMEMB (CAR Y)
                                                                         DECLARETAGSLST))
                                                   collect (CAR Y)))
                                     (CL:EVAL-WHEN (CDDR X))
                                     (PROGN (CDR X))
                                     (LIST X]
                             (SETQ NOCOPY T)))]
                 (MKPROGN DEF]
           (fetch NULLDEF of TYPE))
          (GETDEFERR NAME TYPE OPTIONS))
         DEF])

(GETDEFERR
  [LAMBDA (NAME TYPE OPTIONS MSG)                        (* lmm "13-Jul-85 04:11")
    (DECLARE (USEDFREE NODEF))                           (* ; 
                                       "Message non-null if looking for saved or filed definition.")
    (PROG (TEM)
          (RETURN (COND
                     ((EQMEMB 'NOERROR OPTIONS)              (* ; 
                                               "We want to do the string search in the HASDEF case")
                      (RETURN (fetch NULLDEF of TYPE)))
                     [(AND (NULL MSG)
                           (EQMEMB 'SPELL OPTIONS)
                           (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS)
                                                                          'SPELL)
                                                                   T)))
                           (NEQ TEM NAME))
                      (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS]
                     (T (for O inside OPTIONS when (STRINGP O)
                           do (RETFROM 'GETDEF O)
                           finally (ERROR NAME (CONS TYPE '(definition not found))
                                              T])

(GETDEFFROMFILE
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: " 1-Oct-86 22:10")

    (* ;; "Tries to get definition from source file.  If successful, returns the definition.  Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.")

    (DECLARE (SPECVARS NAME))
    (bind (NOTFOUND _ "not found")
           DEF SOURCE TEM2 for FILE inside (COND
                                                      ((EQ SOURCE 'FILE)
                                                       (WHEREIS NAME TYPE T))
                                                      (T SOURCE))
       when
       (AND
        (SETQ SOURCE (FINDFILE FILE T))
        (NEQ
         [SETQ DEF
          (COND
             ((SETQ TEM2 (fetch FILEGETDEF of TYPE))
              (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND))
             (T
              (SELECTQ TYPE
                  (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  ((VARS FILEVARS) 
                       (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (COND
                     [(SETQ DEF (GET TYPE 'DEFINERS))
                      (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF
                                        `(LAMBDA (FIRST SECOND)
                                           (AND (MEMB FIRST ',DEF)
                                                (OR (EQ SECOND NAME)
                                                    (AND (MEMB SECOND '(%( %[))
                                                         (PROGN (RATOM)
                                                                (RATOM)
                                                                (RATOM)
                                                                (EQ NAME (RATOM]
                                                             (* ; "ick!  Should use real closure")
                           (if (EQ (CAAR VAL)
                                       'NOT-FOUND)
                               then NOTFOUND
                             elseif (CDR VAL)
                               then (CONS 'PROGN VAL)
                             else (CAR VAL]
                     (T (RESETLST
                            (RESETSAVE (RESETUNDO))
                            [LET (LOAD-VERBOSE-STREAM)
                                 (DECLARE (SPECVARS LOAD-VERBOSE-STREAM))
                                                             (* ; 
                                                     "just in case we get a PRETTYCOMPRINT in here")
                                 (LOADFNS NIL SOURCE 'PROP (COND
                                                              ((LITATOM NAME)
                                                             (* ; 
                                         "If an atom, only bother with expressions that contain it")
                                                               (CONS (LIST '& '|..| NAME)))
                                                              (T T]
                            (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))]
         NOTFOUND)) do (AND (EQ SOURCE 'FILE)
                                (OR (FMEMB FILE FILELST)
                                    (CL:FORMAT T "(from ~A)~%%" SOURCE))) 
                                                             (* ; 
                                                        "Copying and dwimifying are done in GETDEF")
                          (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
                                                                  (APPEND '(no definition on)
                                                                         (MKLIST SOURCE])

(GETDEFSAVED
  [LAMBDA (NAME TYPE OPTIONS)                          (* ; "Edited 11-Aug-87 18:14 by cutting")
                                                             (* ; 
                                                           "Gets the `saved' definition--source=T")
    (SELECTQ TYPE
        (FNS (OR (GETPROP NAME 'EXPR)
                 (GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
        (VARS                                                (* ; 
                               "The value of a variable is never substituted into and never COPIED")
              (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
                                                                                'VALUE)
                 do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS 
                                                                     "no saved value for "))))
        (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS)))
            (GETDEFERR NAME TYPE OPTIONS "no saved definition for "])

(PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* ; "Edited  8-Apr-87 12:52 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE)))
         (COND
            (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON))
            (T (SELECTQ TYPE
                   (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON))
                   (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON))
                   (EVAL DEFINITION))
               NAME])

(EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)
    (DECLARE (LOCALVARS . T)
           (SPECVARS SOURCE))                          (* ; "Edited 27-Jul-87 11:04 by cutting")

    (* ;; "lets you edit anything.  Given name and type, call editor on the definition (loading it in from SOURCE if necessary).  If you change it, then the definition gets unsaved.  OPTIONS is passed through from ED to the editor.")

    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (COND
       ((AND (fetch EDITDEF of TYPE)
             (APPLY* (fetch EDITDEF of TYPE)
                    NAME TYPE SOURCE EDITCOMS OPTIONS)))
       ((AND (EQ TYPE 'FNS)
             (NULL SOURCE))                                  (* ; 
                                "special hack for EDITDEF of FNS because of ability to EDITLOADFNS")
        (EDITDEF.FNS NAME EDITCOMS OPTIONS))
       (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))
    NAME])

(DEFAULT.EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 11-Jun-92 16:26 by cat")
    (PROG [(DEF (COND
                   [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
                   [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
                   [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
                   (T (LET ((FILES (WHEREIS NAME TYPE T)))
                           (CL:IF (NULL FILES)
                               (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE)
                               [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME 
                                                         FILES)
                                                  (CL:IF (CL:ENDP (CDR FILES))
                                                      (CL:IF (CL:Y-OR-N-P 
                                                                    "Shall I load this file PROP? ")
                                                             (CAR FILES))
                                                      (ASKUSER NIL NIL 
                                                             "indicate which file to load PROP: "
                                                             (MAKEKEYLST FILES)
                                                             T))]
                                    (CL:WHEN FILE
                                        (LOAD FILE 'PROP)
                                        (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])]

     (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")

          (DECLARE (SPECVARS RETRY))

     (* ;; "what is RETRY ???")

          (SETQ RETRY)
          (CL:WHEN DEF
              (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
                                                             (* ; 
                                             "this function is called when there were changes made")
                                                        (FIXEDITDATE DEF)
                                                             (* ; "fix the edit date first - jtm")
                                                        (PUTDEF NAME TYPE DEF)
                                                        (MARKASCHANGED NAME TYPE 'CHANGED)

                                 (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition.  doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here.  this sometimes results in MARKASCHANGED getting called twice.")

                                                        ]
                     OPTIONS))])

(EDITDEF.FILES
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 18-Mar-87 16:07 by woz")
    (EDITDEF (FILECOMS NAME)
           'VARS SOURCE EDITCOMS OPTIONS])

(LOADDEF
  [LAMBDA (NAME TYPE SOURCE)                             (* lmm "13-SEP-78 01:34")
    (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY])

(DWIMDEF
  [LAMBDA (DEF FN SOURCE)                                (* lmm " 6-Jun-86 17:23")
    (AND [OR (EQ DWIMIFYCOMPFLG T)
             (EQ CLISPIFYPRETTYFLG T)
             (EQ (CAR (CADDR DEF))
                 'CLISP%:)
             (SELECTQ SOURCE
                 ((CURRENT SAVED FILE ?) 
                      NIL)
                 (AND (LITATOM SOURCE)
                      (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE]
         (LET ((NOSPELLFLG T)
               (DWIMESSGAG T)
               FILEPKGFLG LISPXHIST)
              (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST))
              (DWIMIFY0 DEF (COND
                               ((OR (LISTP FN)
                                    (NULL FN))
                                '?)
                               (T FN))
                     NIL DEF])

(DELDEF
  [LAMBDA (NAME TYPE)                                    (* ; "Edited  5-Dec-86 06:20 by lmm")
    (PROG (TEM)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
      LP  [COND
             ((SETQ TEM (fetch DELDEF of TYPE))
              (APPLY* TEM NAME TYPE))
             (T (SELECTQ TYPE
                    (FNS                                     (* ; 
  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such")
                         (AND (EXPRP NAME)
                              (/PUTD NAME))
                         (REMPROP NAME 'EXPR)
                         [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME])
                    (VARS (/SETTOPVAL NAME 'NOBIND))
                    (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES)
                              do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST]
                           (/replace FILEPROP of NAME with NIL)
                           (/replace FILECHANGES of NAME with NIL)
                           (/replace FILEDATES of NAME with NIL)
                           (FLUSHFILEMAPS NAME))
                    (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME)
                                 (DELFROMLIST 'FILEPKGTYPES NAME)
                                 (for FIELD on (FILEPKGCOM NAME)
                                    by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD)
                                                                      NIL))
                                 (for FIELD on (FILEPKGTYPE NAME)
                                    by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD)
                                                                      NIL))
                                 (/replace ALLFIELDS of NAME with NIL))
                    (ALISTS [AND (LISTP NAME)
                                 (DELFROMLIST (CAR NAME)
                                        (FASSOC (CADR NAME)
                                               (GETTOPVAL (CAR NAME])
                    (MACROS (for P in MACROPROPS do (/REMPROP NAME P)))
                    (PROPS (AND (LISTP NAME)
                                (/REMPROP (CAR NAME)
                                       (CADR NAME))))
                    (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS))
                                 (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS
                                                                             ))
                                 (DELFROMLIST 'LISPXCOMS NAME)
                                 (DELFROMLIST 'HISTORYCOMS NAME))
                    (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet")
                           T]
          (MARKASCHANGED NAME TYPE 'DELETED)
          (RETURN NAME])

(DELFROMLIST
  [LAMBDA (VAR VAL)                                      (* rmk%: " 3-JAN-82 23:22")
    (AND (FMEMB VAL (GETTOPVAL VAR))
         (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR)
                                (FUNCTION (LAMBDA (X)
                                            (AND (NEQ X VAL)
                                                 (OR (NLISTP X)
                                                     (NEQ (CDR X)
                                                          VAL])

(HASDEF
  [LAMBDA (NAME TYPE SOURCE SPELLFLG)                    (* ; "Edited 31-Aug-87 18:02 by drc:")

    (* ;; "is NAME the name of something of type TYPE?  NIL SOURCE means 0, not ?")

    (DECLARE (SPECVARS TYPE))
    (COND
       [[OR (LISTP TYPE)
            (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG")
        (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
                                            (RETURN $$VAL]
       (T
        (PROG [(NODEF (fetch NULLDEF of TYPE))
               (OPTS '(NODWIM NOCOPY NOERROR HASDEF]
              (COND
                 ((NULL SOURCE)
                  (SETQQ SOURCE CURRENT)))
              (RETURN
               (SELECTQ SOURCE
                   ((CURRENT 0) 
                        [COND
                           ([OR
                             (MEMBER NAME (fetch CHANGED of TYPE))
                             (LET ((TM (fetch HASDEF of TYPE)))
                                  (COND
                                     (TM (APPLY* TM NAME TYPE SOURCE))
                                     [(NOT (LITATOM NAME))
                                      (SELECTQ TYPE
                                          (PROPS (AND (LISTP NAME)
                                                      (GETPROP (CAR NAME)
                                                             (CADR NAME))))
                                          ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS 
                                                  FIELDS USERMACROS FILEVARS FILEPKGCOMS) 
                                               NIL)
                                          (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                                     (T 
                                        (* ;; "symbol definitions")

                                        (SELECTQ TYPE
                                            (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS")
                                                                        "INTERLISP")))
                                                        (AND SYMBOL (BOUNDP SYMBOL))))
                                            (TEMPLATES (GETTEMPLATE NAME))
                                            (MACROS (GETLIS NAME MACROPROPS))
                                            (LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
                                                             (FASSOC NAME LISPXHISTORYMACROS)))
                                            (VARS (AND (NOT (CL:KEYWORDP NAME))
                                                       (NEQ (GETTOPVAL NAME)
                                                            'NOBIND)))
                                            (RECORDS (RECLOOK NAME))
                                            (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD]
                                                            (RETURN (AND TEM (EQ (CAR TEM)
                                                                                 'FORWORD)
                                                                         (GETPROP (CDR TEM)
                                                                                'I.S.OPR])
                                            (FNS (AND (OR (AND (GETD NAME)
                                                               (EXPRP (GETD NAME)))
                                                          (GET NAME 'EXPR))
                                                      (NOT (HASDEF NAME 'FUNCTIONS SOURCE))))
                                            (FIELDS (RECORDFIELD? NAME))
                                            (USERMACROS (FASSOC NAME USERMACROS))
                                            (FILEVARS)
                                            ((PROPS ALISTS DEFS EXPRESSIONS) 
                                                 NIL)
                                            (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
                                                             (FMEMB NAME FILEPKGTYPES)))
                                            (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                            (OR NAME T))
                           (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME)
                                         (FIXSPELL NAME NIL
                                                (SELECTQ TYPE
                                                    (FILES FILELST)
                                                    (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES))
                                                    (FIELDS (for X in USERRECLST
                                                               join (APPEND (RECORDFIELDNAMES
                                                                                 X))))
                                                    (RECORDS (for X in USERRECLST
                                                                when (LITATOM (CADR X))
                                                                collect (CADR X)))
                                                    (LISPXMACROS LISPXCOMS)
                                                    (I.S.OPRS I.S.OPRLST)
                                                    (USERMACROS (MAPCAR USERMACROS
                                                                       (FUNCTION CAR)))
                                                    USERWORDS)
                                                NIL
                                                (LISTP SPELLFLG)
                                                [FUNCTION (LAMBDA (X)
                                                            (HASDEF X TYPE 'CURRENT]
                                                NIL T))])
                   (? (OR (HASDEF NAME TYPE 'CURRENT)
                          (AND (LITATOM NAME)
                               (HASDEF NAME TYPE 'SAVED SPELLFLG))
                          (WHEREIS NAME TYPE T)))
                   ((SAVED T) 
                        (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS)))
                   (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])

(GETFILEDEF
  [LAMBDA (FILENAME)                                     (* lmm " 4-Jul-85 13:25")

    (* ;; 
  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST")

    (COND
       ((FMEMB FILENAME FILELST)
        FILENAME)
       (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T)
             do (COND
                       ((EQ (FILENAMEFIELD FILE 'NAME)
                            FILENAME)
                        (RETURN FILE])

(SAVEDEF
  [LAMBDA (NAME TYPE DEFINITION)                         (* JonL "24-Jul-84 20:11")
    (COND
       [(AND (LISTP NAME)
             (NULL TYPE))
        (MAPCAR NAME (FUNCTION (LAMBDA (I)
                                 (SAVEDEF I 'FNS]
       (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME)))
                        (/PUT NAME [SETQ TYPE (COND
                                                 ((SUBRP DEFINITION)
                                                  'SUBR)
                                                 ((EXPRP DEFINITION)
                                                  'EXPR)
                                                 ((CCODEP DEFINITION)
                                                  'CODE)
                                                 (T 'LIST]
                              DEFINITION)))
              (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME)))
                              'NOBIND)
                         (EQ DEFINITION (GETTOPVAL NAME))
                         (/PUT NAME (SETQ TYPE 'VALUE)
                               DEFINITION)))
              (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT
                                                          '(NOCOPY NOERROR NODWIM]
                   (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS))
                                                  (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME))
                                                                             SAVEDDEFS]
          TYPE])

(UNSAVEDEF
  [LAMBDA (NAME TYPE DEF)                                (* lmm " 6-Jun-86 17:24")
    (SELECTQ TYPE
        ((NIL EXPR CODE SUBR LIST) 
             (COND
                [(LISTP NAME)                                (* ; "for compatibility")
                 (MAPCAR NAME (FUNCTION (LAMBDA (X)
                                          (UNSAVED1 X TYPE]
                (T (UNSAVED1 NAME TYPE))))
        (PROG NIL
              [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
                                       'SAVED 0))
                  (RETURN (CONS TYPE '(not found]
              (COND
                 ((NEQ DFNFLG T)
                  (SAVEDEF NAME TYPE)
                  (LET ((DFNFLG T))
                       (PUTDEF NAME TYPE DEF)))
                 (T (PUTDEF NAME TYPE DEF)))
              (RETURN TYPE])

(COMPAREDEFS
  [LAMBDA (NAME TYPE SOURCES)                            (* lmm " 4-Jul-85 14:37")
    (COND
       ((AND (LISTP TYPE)
             (GETFILEPKGTYPE SOURCES NIL T))
        (swap TYPE SOURCES)))
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T]
          [COND
             ((NULL SOURCES)
              (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE))
                       (SOME SRCS (FUNCTION (LAMBDA (FILE)
                                              (MEMBER NAME (CDR (ASSOC TYPE
                                                                       (fetch TOBEDUMPED
                                                                          of (fetch FILEPROP
                                                                                    of FILE]
                   (push SRCS 'CURRENT]
          (SETQ SRCS (for SRC in SRCS
                        when (COND
                                    ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
                                          (fetch NULLDEF of TYPE))
                                     (OR [SOME DEFS (FUNCTION (LAMBDA (DP)
                                                                (COMPARELST DEF (CDR DP]
                                         (push DEFS (CONS SRC DEF)))
                                     T)
                                    (T (PRINTOUT T "No " SRC " definition found for " NAME T)
                                       NIL)) collect SRC))
          (RETURN (COND
                     ((NULL SRCS)
                      '(no definitions found))
                     ((NULL (CDR SRCS))
                      '(only one definition found))
                     ((CDR DEFS)
                      [for S1 on (DREVERSE DEFS)
                         do (for S2 on (CDR S1) do (PRIN2 NAME T T)
                                                                  (AND (CAAR S1)
                                                                       (PRIN1 " from " T)
                                                                       (PRIN2 (CAAR S1)
                                                                              T T))
                                                                  (PRIN1 " and " T)
                                                                  (PRIN2 NAME T T)
                                                                  (COND
                                                                     ((CAAR S2)
                                                                      (PRIN1 " from " T)
                                                                      (PRIN2 (CAAR S2)
                                                                             T T)))
                                                                  (PRIN1 " differ:" T)
                                                                  (TERPRI T)
                                                                  (COMPARELISTS (CDAR S1)
                                                                         (CDAR S2]
                      'DIFFERENT)
                     (T 'SAME])

(COMPARE
  [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2)             (* lmm " 5-SEP-78 13:37")
    (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY]
           (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY]
          (COND
             ((COMPARELST DEF1 DEF2)
              (RETURN)))
          (PRIN2 NAME1 T T)
          (COND
             (SOURCE1 (PRIN1 " from " T)
                    (PRIN2 SOURCE1 T T)))
          (PRIN1 " and " T)
          (PRIN2 NAME2 T T)
          (COND
             (SOURCE2 (PRIN1 " from " T)
                    (PRIN2 SOURCE2 T T)))
          (PRIN1 " differ:" T)
          (TERPRI T)
          (COMPARELISTS DEF1 DEF2)
          (RETURN T])

(TYPESOF
  [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER)
                                                          (* ; "Edited  2-Aug-88 02:08 by masinter")

    (* ;; "return list of all known types which NAME names")

    (LET
     (FOUND SHADOWED)
     (if (FMEMB SOURCE '(? NIL))
         then (CL:FLET [(RSHADOW NIL (for X in FOUND
                                            do (for Y in (CDR (FASSOC X SHADOW-TYPES))
                                                      do (if (FMEMB Y FOUND)
                                                                 then 
                                                             (* ; "shadower found before shadowed")
                                                                       (SETQ FOUND (REMOVE Y FOUND]
                         (LET (NOTFOUND NEWTYPES)
                              (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                                 when [AND (LITATOM TYPE)
                                               (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                               (OR (NULL FILTER)
                                                   (CL:FUNCALL FILTER TYPE))
                                               (NOT (find X in FOUND
                                                       suchthat (FMEMB TYPE
                                                                           (CDR (FASSOC X 
                                                                                       SHADOW-TYPES]
                                 do (if [OR (HASDEF NAME TYPE 'CURRENT)
                                                    (AND (LITATOM NAME)
                                                         (HASDEF NAME TYPE 'SAVED]
                                            then (push FOUND TYPE)
                                          else (push NOTFOUND TYPE)))
                              (RSHADOW)
                              [for FILE in FILELST while NOTFOUND
                                 when [NEQ T (fetch LOADTYPE of (GETPROP FILE
                                                                                   'FILE]
                                 do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND
                                                                      (FILECOMS FILE)
                                                                      'TYPESOF))
                                            then [bind X for TYPE in NEWTYPES
                                                        when (FMEMB TYPE NOTFOUND)
                                                        do (push FOUND TYPE)
                                                              (if (SETQ X (FASSOC TYPE 
                                                                                     SHADOW-TYPES))
                                                                  then (SETQ NOTFOUND
                                                                            (LDIFFERENCE NOTFOUND X))
                                                                else (SETQ NOTFOUND
                                                                          (REMOVE TYPE NOTFOUND]
                                                  (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES]
                              (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF))
                                  then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND))
                                        (SETQ FOUND (UNION NEWTYPES FOUND)))
                              (RSHADOW)
                              FOUND))
       else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                   when (AND (LITATOM TYPE)
                                 (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                 (OR (NULL FILTER)
                                     (CL:FUNCALL FILTER TYPE))
                                 (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE)))
     FOUND])
)

(RPAQ? WHEREIS.HASH )



(* ; "Must come after PUTDEF")

(DEFINEQ

(FIXEDITDATE
  [LAMBDA (EXPR)                                         (* ; "Edited 17-Jul-89 11:13 by jtm:")
                                                             (* NOBIND "18-JUL-78 21:11")
                                                             (* Inserts or replaces previous edit 
                                                           date)
    (AND INITIALS (LISTP EXPR)
         (LISTP (CDR EXPR))
         (PROG (E)
               (COND
                  ((FMEMB (CAR EXPR)
                          LAMBDASPLST)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR)))
                  [(FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-ARGLIST-DEFINERS)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR))
                   (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
                      finally (SETQ E (CDR E]
                  ((FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-NAME-DEFINERS)

                   (* ;; "insert the edit date after the name")

                   (SETQ E (CDDR EXPR)))
                  (T (RETURN)))
           RETRY
               [COND
                  ((NLISTP E)
                   (RETURN))
                  ((LISTP (CAR E))
                   (SELECTQ (CAAR E)
                       ((CLISP%: DECLARE) 
                            (SETQ E (CDR E))
                            (GO RETRY))
                       (BREAK1 (COND
                                  ((EQ (CAR (CADAR E))
                                       'PROGN)
                                   (SETQ E (CDR (CADAR E)))
                                   (GO RETRY))))
                       (ADV-PROG                             (* No easy way to mark cleanly the 
                                                           date of an advised function)
                                 (RETURN))
                       (COND
                          ((AND (EQ (CAAR E)
                                    COMMENTFLG)
                                (EQ (CADAR E)
                                    'DECLARATIONS%:))
                           (SETQ E (CDR E))
                           (GO RETRY]
               (COND
                  ([for TAIL on E while (AND (LISTP (CAR TAIL))
                                                         (EQ (CAAR TAIL)
                                                             COMMENTFLG))
                      do (COND
                                ((AND (LISTP (CDR TAIL))
                                      (EDITDATE? (CAR TAIL)))
                                 (/RPLACA TAIL (EDITDATE (CAR TAIL)
                                                      INITIALS))
                                 (RETURN T]                  (* scans the comments for a 
                                                           timestamp for this user.)
                   NIL)
                  (T                                         (* attach the new timestamp at the 
                                                           beginning of the comments.)
                     (/ATTACH (EDITDATE NIL INITIALS)
                            E)))
               (RETURN EXPR])

(EDITDATE?
  [LAMBDA (COMMENT)                                      (* ; "Edited 11-Jun-92 16:44 by cat")
                                                             (* ; "Edited 13-Jul-89 09:30 by jtm:")
                                                             (* lmm "21-Mar-85 08:45")

         (* Tests to see if a given common is in fact an edit date --
       this has to be general enough to recognize the most comment comment forms while 
       specific enough to not recognize things that are not edit dates)

    (DECLARE (LOCALVARS . T))                            (* jtm%: changed test so that it 
                                                           creates one timestamp per user.)
    (COND
       [(LISTP COMMENT)
        (COND
           ((EQ (CAR COMMENT)
                COMMENTFLG)
            [COND
               (NIL (NULL NORMALCOMMENTSFLG)
                    (SETQ COMMENT (GETCOMMENT COMMENT]
            (COND
               ([OR (NOT (LISTP (CDR COMMENT)))
                    (NOT (LISTP (CDDR COMMENT]
                NIL)
               [(EQ (CADR COMMENT)
                    ';)                                      (* ; "CL style comment")
                (STRPOS INITIALS (CADDR COMMENT)
                       (IMINUS (NCHARS INITIALS]
               (T                                            (* ; "IL style comment")
                  (EQ (CADR COMMENT)
                      INITIALS]
       ((STRINGP COMMENT])
)



(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")


(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))

(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
)



(* ;; 
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
)

(DEFINEQ

(FILEPKGCOM
  [LAMBDA N                                              (* JonL "10-Jul-84 19:38")
    (PROG (TEM (COM (ARG N 1)))
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in '(MACRO CONTENTS DELETE ADD)
                             when (SETQ TEM (FILEPKGCOM COM FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                               (LIST 'COM T))
                          (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                               (LIST 'COM TEM]
                     ((EQ N 2)
                      (SELECTQ (ARG N 2)
                          (ADD (fetch ADD of COM))
                          (DELETE (fetch DELETE of COM))
                          (MACRO (fetch MACRO of COM))
                          ((CONTENTS CONTAIN) 
                               [OR (fetch (FILEPKGCOM CONTENTS) of COM)
                                   (COND
                                      ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM))
                                       (COND
                                          ((EQ COM 'NILL)
                                           COM)
                                          [(EQ (CAR COM)
                                               'LAMBDA)
                                           (CONS (CAR COM)
                                                 (CONS [CONS (CAADR COM)
                                                             (CONS (OR (CADDR (CADR COM))
                                                                       'NAME)
                                                                   (CONS (CADR (CADR COM))
                                                                         (CDDDR (CADR COM]
                                                       (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM]
                                          (T (LIST 'LAMBDA '(COM TYPE NAME)
                                                   (CONS COM '(COM TYPE NAME])
                          (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                        T)
                                   (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST])
                          (ERROR (ARG N 2)
                                 "not file package command property")))
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'COM)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                (/SETTOPVAL 'FILEPKGCOMSPLST
                                                       (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST])
                                         (COND
                                            ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGCOMSPLST
                                                      (CONS (CONS COM TEM)
                                                            (GETTOPVAL 'FILEPKGCOMSPLST]
                                    (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                    (/SETTOPVAL 'FILEPKGCOMSPLST
                                                           (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                       (SELECTQ (ARG N I)
                                           (ADD (/replace (FILEPKGCOM ADD) of COM
                                                   with TEM))
                                           (DELETE (/replace (FILEPKGCOM DELETE) of
                                                                                         COM
                                                      with TEM))
                                           (MACRO (/replace (FILEPKGCOM MACRO) of COM
                                                     with TEM))
                                           ((CONTENTS CONTAIN) 
                                                (/replace (FILEPKGCOM CONTENTS) of COM
                                                   with TEM))
                                           (ERROR (ARG N I)
                                                  "not file package command property"]
                        (MARKASCHANGED COM 'FILEPKGCOMS])

(FILEPKGTYPE
  [LAMBDA N                                              (* lmm " 5-Jul-85 09:07")
    (PROG ((TYPE (ARG N 1))
           TEM)
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in (UNION '(DESCRIPTION)
                                                       FILEPKGTYPEPROPS)
                             when (SETQ TEM (FILEPKGTYPE TYPE FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                               (LIST 'TYPE T))
                          (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]
                               (LIST 'TYPE TEM]
                     [(EQ N 2)
                      (if (FMEMB (ARG N 2)
                                     FILEPKGTYPEPROPS)
                          then (GETPROP TYPE (ARG N 2))
                        else (SELECTQ (ARG N 2)
                                     (DESCRIPTION (fetch DESCRIPTION of TYPE))
                                     (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                                                    T)
                                               (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES])
                                     (ERROR (ARG N 2)
                                            "not file package type property"]
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'TYPE)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T (OR (FMEMB TYPE FILEPKGTYPES)
                                                (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES))))
                                         (COND
                                            ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES))
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM)
                                                                               FILEPKGTYPES]
                                    (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES)
                                                    (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES
                                                                                    ]
                                       (if (FMEMB (ARG N I)
                                                      FILEPKGTYPEPROPS)
                                           then (if TEM
                                                        then (/PUTPROP TYPE (ARG N I)
                                                                        TEM)
                                                      else (/REMPROP TYPE (ARG N I)))
                                         else (SELECTQ (ARG N I)
                                                      (DESCRIPTION (/replace DESCRIPTION
                                                                      of TYPE with TEM))
                                                      (ERROR (ARG N I)
                                                             "not file package command/type property"
                                                             ]
                        (MARKASCHANGED TYPE 'FILEPKGCOMS])
)

(PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS)))

(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)

(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE)
                                                                       (* Revert to NILL when no 
                                                                          longer coercing 
                                                                          PRETTYDEFMACROS to 
                                                                          FILEPKGCOMS)
                                                                       (AND (EQ TYPE 'FILEPKGCOMS)
                                                                            (INFILECOMTAIL COM]
                                                  (TYPE DESCRIPTION "file package commands/types" 
                                                        GETDEF T PUTDEF FILEPKGCOMS.PUTDEF)))
(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X]
                                             (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF 
                                                   WHENCHANGED (ALISTS.WHENCHANGED))))
(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X])
(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS)))
(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED (
                                                                              EXPRESSIONS.WHENCHANGED
                                                                                               )
                                                        EDITDEF NILL)))
(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL)))
(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)
                                                   (TYPE TYPE FILEPKGCOMS)))
(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X]
                                                 CONTENTS
                                                 (LAMBDA (COM NAME TYPE)
                                                        (AND (EQ TYPE 'FILES)
                                                             (SUBSET (INFILECOMTAIL COM)
                                                                    (FUNCTION LITATOM]
                                            (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED)
                                                  EDITDEF EDITDEF.FILES)))
(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X)))
                                               (TYPE NULLDEF NOBIND EDITDEF NILL)))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (FN)
                                                                         (AND (GETPROP FN
                                                                                     'FUNCTIONS)
                                                                              (CL:WARN 
                                                                      "~A has a FUNCTIONS definition"
                                                                                     FN]
                                                  (ORIGINAL (FNS . X)))
                                               CONTENTS NILL)
                                          (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF
                                                T)))
(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X)))
                                                       CONTENTS
                                                       (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                              (AND (NULL ONFILETYPE)
                                                                   (EQ TYPE 'RECORDS)
                                                                   (INFILECOMTAIL COM])
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS)))
(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X)))
                                                       CONTENTS NILL)
                                                  (TYPE DESCRIPTION "LISPX commands")))
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM
                                              MACRO
                                              [X
                                               (DECLARE%:
                                                EVAL@COMPILE
                                                (P
                                                 *
                                                 (MAPCAR
                                                  'X
                                                  (FUNCTION
                                                   (LAMBDA (Y)
                                                          (LET [[FNDEF (GETDEF Y 'FUNCTIONS
                                                                              'CURRENT
                                                                              '(NOCOPY NOERROR]
                                                                (MACDEF (GETDEF Y 'MACROS
                                                                               'CURRENT
                                                                               '(NOCOPY NOERROR]
                                                               (COND
                                                                ((AND FNDEF (EQ (CAR FNDEF)
                                                                                'DEFMACRO))
                                                                 (CL:WARN 
                           "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S."
                                                                        FNDEF)
                                                                 (LIST 'PROGN FNDEF MACDEF))
                                                                (T (OR MACDEF (CL:CERROR 
                                                          "Go ahead and finish writing out the file."
                                                                                     
                                                                       "No MACROS definition for ~A."
                                                                                     Y)
                                                                       (GETDEF Y 'MACROS 'CURRENT]
                                              CONTENTS NILL)
                                             (TYPE DESCRIPTION "Interlisp macros" GETDEF 
                                                   MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY))))
(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)))
(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X]
                                            (TYPE DESCRIPTION "property lists" WHENCHANGED (
                                                                                    PROPS.WHENCHANGED
                                                                                            ))))
(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM
                                               MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (RECORD)
                                                                         (AND (GETPROP RECORD
                                                                                     'STRUCTURES)
                                                                              (CL:WARN 
                                                                     "~A has a STRUCTURES definition"
                                                                                     RECORD]
                                                  (E (RECORDECLARATIONS . X))
                                                  (INITRECORDS . X))
                                               CONTENTS
                                               (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                      (AND (EQ TYPE 'FIELDS)
                                                           (NULL ONFILETYPE)
                                                           (MAPCONC (INFILECOMTAIL COM)
                                                                  (FUNCTION (LAMBDA
                                                                             (X)
                                                                             (APPEND (
                                                                                     RECORDFIELDNAMES
                                                                                      X]
                                              (TYPE DESCRIPTION "records" DELDEF
                                                    (LAMBDA (X)
                                                           (/SETTOPVAL 'USERRECLST
                                                                  (REMOVE (RECLOOK X)
                                                                         USERRECLST])
(PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X)))
                                                      CONTENTS
                                                      (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                             (AND (NULL ONFILETYPE)
                                                                  (EQ TYPE 'RECORDS)
                                                                  (INFILECOMTAIL COM])
(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X)))
                                                      CONTENTS NILL)
                                                 (TYPE DESCRIPTION "edit macros")))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                                (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                          (VAR)
                                                                          (AND (GETPROP VAR
                                                                                      'VARIABLES)
                                                                               (CL:WARN 
                                                                 "~A also has a VARIABLES definition"
                                                                                      VAR]
                                                   (ORIGINAL (VARS . X)))
                                                CONTENTS NILL)
                                           (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF 
                                                 VARS.PUTDEF)))
(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL)))
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X)
                                                                     (P (CONSTANTS . X])

(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
                           (VARIABLES VARS CONSTANTS))

(RPAQ? SAVEDDEFS )



(* ; "EDITCALLERS")

(DEFINEQ

(FINDCALLERS
  [LAMBDA (ATOMS FILES)                                  (* lmm "30-SEP-78 01:36")
    (PROG ((X (EDITCALLERS ATOMS FILES T)))
          (RETURN (NCONC (DREVERSE (CDR X))
                         (AND (CAR X)
                              (LIST (CONS (COND
                                             ((CDR X)
                                              '"plus other places on")
                                             (T 'on))
                                          (CAR X])

(EDITCALLERS
  [LAMBDA (ATOMS FILES COMS)                            (* ; "Edited 18-Apr-2018 10:41 by rmk:")
                                                             (* bvm%: " 3-Nov-86 17:30")
    (LET
     (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN)
     [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS]
     [for FILE in (COND
                             ((NULL FILES)
                              FILELST)
                             ((EQ FILES T)
                              (UNION SYSFILES FILELST))
                             ((LISTP FILES)
                              FILES)
                             (T (LIST FILES)))
        do
        (RESETLST
            [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I)
                  (OR (SETQ FULL (FINDFILE FILE))
                      (RETURN (LISPXPRINT (CONS FILE '(not found))
                                     T T)))
                  [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT]
                  (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM)))
                  (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP)
                         (OR (GET-ENVIRONMENT-AND-FILEMAP FULL)
                             (\PARSE-FILE-HEADER FILESTREAM)))

             (* ;; "Get reader environment of file.  The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists.  Otherwise, read the top of the file")

                  (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV)))
                  (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL))
                  [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS)))
                      (push FFILEPOSPATTERNS
                             (CONS RDTBL (SETQ PATTERNS
                                          (for ATOM in ATOMS
                                             collect (CONCAT
                                                          (COND
                                                             ((EQ (CHCON1 ATOM)
                                                                  (CHARCODE ESCAPE))
                                                              (SETQ ATOM (SUBSTRING ATOM 2 -1))
                                                              "")
                                                             (T " "))
                                                          [COND
                                                             ((SETQ I (STRPOS ' ATOM))
                                                              (SUBSTRING ATOM 1 (SUB1 I)))
                                                             ((STRINGP ATOM))
                                                             (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE
                                                                                  ATOM)))
                                                             (* ; 
                                                           "Keep MKSTRING from putting a prefix on")
                                                                     (MKSTRING ATOM T RDTBL]
                                                          (COND
                                                             (I "")
                                                             (T " "]
                  (for PATTERN in PATTERNS
                     do
                     (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0)))
                     (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA))
                        do
                        (COND
                           ((NULL PRINTFLG)                  (* ; 
                                   "cause the printing of the filename to be saved on history list")
                            (SETQ PRINTFLG T)
                            (LISPXPRIN2 FULL T T T)

                            (* ;; "print with NODOFLG=T means just to record the printing;  the idea is that only those files in which something is found will be remembered on the history list")

                            (LISPXPRIN1 ": " T NIL T)))
                        [OR
                         [AND (NEQ MAP T)
                              (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0)
                                                                    (SETQ MAP (OR (GETFILEMAP 
                                                                                         FILESTREAM)
                                                                                  (LOADFILEMAP 
                                                                                         FILESTREAM]
                                                         (PROGN 
                                                             (* ; "file has no filemap")
                                                                (SETQ MAP (SETQ NOMAPFLG T))
                                                                (LISPXPRIN1 " no filemap!" T)
                                                                NIL)))
                                 thereis (AND (ILESSP (CAR X)
                                                         I)
                                                  (IGREATERP (CADR X)
                                                         I)
                                                  (for Z in (CDDR X)
                                                     thereis (COND
                                                                    ((AND (ILESSP (CADR Z)
                                                                                 I)
                                                                          (IGREATERP (CDDR Z)
                                                                                 I))
                                                                     [COND
                                                                        ((NOT (FMEMB (CAR Z)
                                                                                     FNS))
                                                                         (SETQ FNS
                                                                          (CONS (LISPXPRIN2
                                                                                 (CAR Z)
                                                                                 T T)
                                                                                FNS]
                                                                     (SETQ I (CDDR Z))
                                                                     T]
                         (PROGN (LISPXPRIN2 I T T)
                                (OR (FMEMB FILE OTHERSFILES)
                                    (SETQ OTHERSFILES (CONS FILE OTHERSFILES]
                        (LISPXSPACES 1 T)))
                  (COND
                     (PRINTFLG (LISPXTERPRI T))
                     (T (TERPRI T)))
                  (COND
                     ((NEQ COMS T)
                      (COND
                         ((OR FNS OTHERSFILES)
                          (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS))
                                 FULL EDITPATTERN COMS (NULL OTHERSFILES))
                          (SETQ OTHERSFILES)
                          (SETQ FNS])]
     (COND
        ((EQ COMS T)
         (CONS OTHERSFILES FNS])

(EDITFROMFILE
  [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES)     (* rmk%: "14-Mar-85 21:51")
    (RESETVARS [(EDITLOADFNSFLG (COND
                                   ((EQ EDITLOADFNSFLG T)
                                    '(T . NO))
                                   (T EDITLOADFNSFLG]
               (PROG NIL
                     [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN]
                     (AND
                      (SETQ FILES (for FILE inside (OR FILES FILELST)
                                     when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE)
                                                                             FILELST))
                                                  (COND
                                                     ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" 
                                                                                        FILE)
                                                                    NIL T))
                                                      (LOADFROM FILE FNS 'ALLPROP)
                                                      T))) collect FILE))
                      (for TYPE in [COND
                                              ((LISTP ONLYTYPES))
                                              (ONLYTYPES '(FNS))
                                              (T 

                                 (* ;; "Move FNS to the front.  This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.")

                                                 (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES]
                         when (AND (LITATOM TYPE)
                                       (NEQ (fetch EDITDEF of TYPE)
                                            'NILL))
                         do
                         (PROG (SEEN)
                               (for FILE inside FILES
                                  do
                                  (for NAME in [COND
                                                          ((AND (EQ TYPE 'FNS)
                                                                (NEQ FNS T))
                                                             (* ; 
                                                    "for this type, we are given the list of items")
                                                           (PROG1 FNS (SETQ FNS NIL)))
                                                          (T (* ; 
                             "only want the values of `TYPE' which are not part of some other type")
                                                             (FILECOMSLST FILE TYPE 'EDIT]
                                     unless (MEMBER NAME SEEN)
                                     do
                                     (ERSETQ
                                      (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT
                                                             '(NOCOPY NOERROR))
                                                      (GETDEF NAME TYPE 'SAVED
                                                             '(NOCOPY NOERROR]

                                 (* ;; "If definition has been loaded, it may have been editted.  Work on that explicitly instead of bringing in a file definition to smash the users previous changes.  Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS.  --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file.  But ...  rmk")

                                            (COND
                                               ((OR (AND (EQ TYPE 'FNS)
                                                         (NEQ FNS T))
                                                    (AND (LISTP DEF)
                                                         (LOOKIN DEF EDITPATTERN)))
                                                (COND
                                                   ((NULL SEEN)
                                                    (LISPXPRIN1 "editing the " T)
                                                    (LISPXPRIN1 (OR (fetch DESCRIPTION
                                                                       of TYPE)
                                                                    TYPE)
                                                           T)
                                                    (LISPXSPACES 1 T)))
                                                (SETQ SEEN (CONS NAME SEEN))
                                                (LISPXPRIN2 NAME T T)
                                                (LISPXPRIN1 ":
" T)
                                                (COND
                                                   ((NOT
                                                     (ERSETQ (EDITDEF
                                                              NAME TYPE
                                                              (OR (AND DEF (CONS '= DEF))
                                                                  FILE)
                                                              EDITCOMS)))
                                                    (LISPXPRIN1 "failed" T)))
                                                (LISPXTERPRI T])

(FINDATS
  [LAMBDA (X L)                                          (* lmm "11-FEB-78 16:03")
    (COND
       ((NLISTP X)
        (FMEMB X L))
       (T (OR (FINDATS (CAR X)
                     L)
              (FINDATS (CDR X)
                     L])

(LOOKIN
  [LAMBDA (X PAT)                                        (* lmm "11-MAR-78 14:20")
    (COND
       ([AND (EQ (CAR PAT)
                 '*ANY*)
             (EVERY (CDR PAT)
                    (FUNCTION (LAMBDA (X)
                                (AND (LITATOM X)
                                     (NOT (STRPOS ' X]
        (FINDATS X (CDR PAT)))
       (T (EDITFINDP X PAT T])
)
(DEFINEQ

(SEPRCASE
  [LAMBDA (CLFLG RDTBL)                                  (* bvm%: "24-Oct-86 18:16")

    (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent.  Based on FILERDTBL, but others are close with respect to breaks and seprs")

    (OR RDTBL (SETQ RDTBL FILERDTBL))
    (OR [ARRAYP (CDR (ASSOC RDTBL (COND
                                     (CLFLG CLISPCASEARRAYS)
                                     (T SEPRCASEARRAYS]
        (LET ((CA (CASEARRAY)))
             [if (READTABLEPROP RDTBL 'CASEINSENSITIVE)
                 then                                    (* ; "map upper into lower case")
                       (for I from (CHARCODE A) to (CHARCODE Z)
                          do (SETCASEARRAY CA I (+ I (- (CHARCODE a)
                                                            (CHARCODE A]
             (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS
                                                    collect (CHCON1 Y)))
                                      (GETSEPR RDTBL)
                                      (GETBRK RDTBL)) do (SETCASEARRAY CA X 0))
             (if *PACKAGE*
                 then                                    (* ; 
                               "symbols qualified with package prefix will otherwise be unfindable")
                       (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR)
                              0))
             (SETQ CA (CONS RDTBL CA))
             (COND
                (CLFLG (push CLISPCASEARRAYS CA))
                (T (push SEPRCASEARRAYS CA)))
             (CDR CA])
)

(RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL))

(RPAQ? SEPRCASEARRAYS )

(RPAQ? CLISPCASEARRAYS )

(MOVD? 'INFILEP 'FINDFILE)

                                                             (* ; "or else from SPELLFILE")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
       (NOLINKFNS LOADFROM))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)
)



(* ; "EXPORT")

(DEFINEQ

(IMPORTFILE
  [LAMBDA (FILE RETURNFLG)                               (* lmm " 6-Jun-86 17:43")
    (RESETLST
        [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT]
        (RESETSAVE (INPUT FILE))                             (* ; 
                "Reset INPUT in case some form on the file's action is to read the next expression")
        (NCONC [COND
                  ((EQ RETURNFLG T)                          (* ; 
                                           "Just creating EXPORTS.ALL, don't side-effect the world")
                   (IMPORTFILESCAN FILE RETURNFLG))
                  (T (LET (FILEPKGFLG DFNFLG)
                          (IMPORTFILESCAN FILE RETURNFLG]
               (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE))
                                     ''IMPORTDATE
                                     (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE]
                      RETURNFLG)))])

(IMPORTEVAL
  [LAMBDA (FORM RETURNFLG)                               (* ; "Edited  2-May-87 18:57 by Pavel")

    (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")

    (AND (LISTP FORM)
         (SELECTQ (CAR FORM)
             (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (/DECLAREDATATYPE                               (* ; 
                    "Ignore datatype initializations -- we only need the record declaration itself")
                  NIL)
             (PROGN                                          (* ; "default: eval and/or return it")
                    (AND (NEQ RETURNFLG T)
                         (EVAL FORM))
                    (AND RETURNFLG (LIST FORM])

(IMPORTFILESCAN
  [LAMBDA (FILE RETURNFLG)                               (* bvm%: "24-Oct-86 19:31")
    (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
        (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
           join (until (EQUAL (SETQ DEF (READ FILE))
                                      ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])

(CHECKIMPORTS
  [LAMBDA (FILES NOASKFLG)                               (* rmk%: "19-FEB-83 16:31")
                                                             (* ; 
                                           "Loads exported definitions from new versions of FILES.")
    (COND
       ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE
                            when [AND (SETQ FULLFILENAME (FINDFILE FILE T))
                                          (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE)
                                                                     'IMPORTDATE]
                                              (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 
                                                                     'ICREATIONDATE]
                            collect (LIST FILE FULLFILENAME)))
             (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from "
                                                       (MAPCAR FILES (FUNCTION CAR)))
                                          '((Y "es
")
                                            (N "o
"))
                                          T)
                              (N NIL)
                              T)))
        (for FILE in FILES do (IMPORTFILE (CADR FILE])

(GATHEREXPORTS
  [LAMBDA (FROMFILES TOFILE FLG)                         (* bvm%: "14-Oct-86 23:12")
                                                             (* ; 
                                        "Copies all exported definitions from FROMFILES to TOFILE.")
    (RESETLST
        [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE)
                             (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT]
        (RESETSAVE (OUTPUT TOFILE))
        (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*))
             (SETQ ENV (if ENV
                           then (\DO-DEFINE-FILE-INFO NIL ENV)
                         else *OLD-INTERLISP-READ-ENVIRONMENT*))
             (WITH-READER-ENVIRONMENT ENV
                 (PRINT-READER-ENVIRONMENT ENV)
                 (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T)
                        " ON "
                        (DATE)
                        "%"  T)" T "(LISPXTERPRI T)" T)
                 (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T))
                                                              (FUNCTION PRINT))
                                                       (TERPRI))
                 (PRINT 'STOP)
                 (TERPRI)
                 (FULLNAME TOFILE))))])

(\DUMPEXPORTS
  [NLAMBDA COMS                                          (* bvm%: "24-Oct-86 19:42")

(* ;;; "Dumps an EXPORT form.  IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.")

    (PRIN1 "(")
    (PRIN2 '*)
    (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2))               (* ; 
                                   "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE")
    (for TAIL on COMS do (PRETTYCOM (CAR TAIL)))
    (TERPRI)
    (PRINT ENDEXPORTDEFFORM)
    (TERPRI])
)
(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X])

(RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")

(RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)
)



(* ; "for GAINSPACE")

(DEFINEQ

(CLEARFILEPKG
  [LAMBDA (FLG)                                          (* bvm%: "29-Aug-86 13:02")
    (PROG NIL
          (COND
             ((SELECTQ FLG
                  ((E T) 
                       T)
                  (Y (TERPRI T)
                     (PRIN1 "you can delete just the filemaps -
" T)
                     (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? "
                                   '((Y "es - everything" RETURN T)
                                     (N "o - just the filemaps" RETURN NIL)
                                     (E "verything" RETURN T)
                                     (F "ilemaps only" RETURN NIL]
                            (TERPRI T)))
                  NIL)
              (UPDATEFILES)
              [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE)
                                                        (COND
                                                           ((fetch TOBEDUMPED
                                                               of (fetch FILEPROP
                                                                         of FILE))
                                                            (PRINT FILE T T)
                                                            (PRIN1 " has changes, not wiped." T)
                                                            (TERPRI T)
                                                            T)
                                                           (T (replace FILEPROP of FILE
                                                                 with NIL)
                                                              (replace FILECHANGES of FILE
                                                                 with NIL)
                                                              (SMASHFILECOMS FILE)
                                                              (NCONC1 SYSFILES FILE)
                                                              NIL]
              (SETQ LOADEDFILELST)))
          (SELECTQ FLG
              ((NIL T))
              (CLRHASH *FILEMAP-HASH*])
)

(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                    ((Y "es")
                                     (N "o")
                                     (E . "verything")
                                     (F "ilemaps only%
-"))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SMASHPROPSLST1)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST 
       DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS 
       LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG 
       MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS 
       FILEPKGTYPEPROPS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
       (SPECVARS COMSNAME))

(BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
       (NOLINKFNS . T)
       (SPECVARS COMSNAME)
       (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))

(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS 
       INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
       (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
       INFILECOMSPROP)

(BLOCK%: NIL MAKEFILE (LOCALVARS . T)
       (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))

(BLOCK%: ADDFILE ADDFILE ADDFILE0)

(BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))

(BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
       COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF 
       EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE
       FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES 
       MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED 
       MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
       SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF 
       UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS 
                          EDITLOADFNSFLG LOADOPTIONS)
       (LOCALVARS . T))

(BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))

(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
       GETDEFSAVED (RETFNS GETDEFCOM)
       (NOLINKFNS . T)
       (GLOBALVARS NOT-FOUNDTAG))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS 
                          MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS 
                          PRETTYDEFMACROS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1995 2018 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (22680 24385 (SEARCHPRETTYTYPELST 22690 . 23669) (PRETTYDEFMACROS 23671 . 24129) (
FILEPKGCOMPROPS 24131 . 24383)) (25182 59123 (CLEANUP 25192 . 26580) (COMPILEFILES 26582 . 26858) (
COMPILEFILES0 26860 . 27580) (CONTINUEDIT 27582 . 29002) (MAKEFILE 29004 . 40646) (FILECHANGES 40648
 . 42983) (FILEPKG.MERGECHANGES 42985 . 43808) (FILEPKG.CHANGEDFNS 43810 . 44122) (MAKEFILE1 44124 . 
48394) (COMPILE-FILE? 48396 . 49728) (MAKEFILES 49730 . 51423) (ADDFILE 51425 . 53946) (ADDFILE0 53948
 . 58084) (LISTFILES 58086 . 59121)) (59811 95051 (FILEPKGCHANGES 59821 . 61171) (GETFILEPKGTYPE 61173
 . 64246) (MARKASCHANGED 64248 . 65885) (FILECOMS 65887 . 66271) (WHEREIS 66273 . 67693) (
SMASHFILECOMS 67695 . 67930) (FILEFNSLST 67932 . 68094) (FILECOMSLST 68096 . 68580) (UPDATEFILES 68582
 . 73882) (INFILECOMS? 73884 . 75787) (INFILECOMTAIL 75789 . 76929) (INFILECOMS 76931 . 77092) (
INFILECOM 77094 . 87303) (INFILECOMSVALS 87305 . 87632) (INFILECOMSVAL 87634 . 88636) (INFILECOMSPROP 
88638 . 89467) (IFCPROPS 89469 . 90730) (IFCEXPRTYPE 90732 . 91243) (IFCPROPSCAN 91245 . 92298) (
IFCDECLARE 92300 . 93611) (INFILEPAIRS 93613 . 93945) (INFILECOMSMACRO 93947 . 95049)) (95086 125181 (
FILES? 95096 . 97289) (FILES?1 97291 . 97941) (FILES?PRINTLST 97943 . 98725) (ADDTOFILES? 98727 . 
108648) (ADDTOFILE 108650 . 109566) (WHATIS 109568 . 111544) (ADDTOCOMS 111546 . 113190) (ADDTOCOM 
113192 . 119739) (ADDTOCOM1 119741 . 120912) (ADDNEWCOM 120914 . 121964) (MAKENEWCOM 121966 . 123809) 
(DEFAULTMAKENEWCOM 123811 . 125179)) (125251 128068 (MERGEINSERT 125261 . 127604) (MERGEINSERT1 127606
 . 128066)) (129806 140718 (DELFROMFILES 129816 . 130666) (DELFROMCOMS 130668 . 132347) (DELFROMCOM 
132349 . 138217) (DELFROMCOM1 138219 . 139016) (REMOVEITEM 139018 . 139892) (MOVETOFILE 139894 . 
140716)) (140932 143301 (SAVEPUT 140942 . 143299)) (143426 151750 (UNMARKASCHANGED 143436 . 145144) (
PREEDITFN 145146 . 147657) (POSTEDITPROPS 147659 . 150160) (POSTEDITALISTS 150162 . 151748)) (151899 
172453 (ALISTS.GETDEF 151909 . 152288) (ALISTS.WHENCHANGED 152290 . 152934) (CLEARCLISPARRAY 152936 . 
154110) (EXPRESSIONS.WHENCHANGED 154112 . 154486) (MAKEALISTCOMS 154488 . 155561) (MAKEFILESCOMS 
155563 . 157000) (MAKELISPXMACROSCOMS 157002 . 159020) (MAKEPROPSCOMS 159022 . 159720) (
MAKEUSERMACROSCOMS 159722 . 161522) (PROPS.WHENCHANGED 161524 . 162145) (FILEGETDEF.LISPXMACROS 162147
 . 163589) (FILEGETDEF.ALISTS 163591 . 164210) (FILEGETDEF.RECORDS 164212 . 165143) (FILEGETDEF.PROPS 
165145 . 165937) (FILEGETDEF.MACROS 165939 . 166999) (FILEGETDEF.VARS 167001 . 167417) (FILEGETDEF.FNS
 167419 . 168783) (FILEPKGCOMS.PUTDEF 168785 . 171225) (FILES.PUTDEF 171227 . 172184) (VARS.PUTDEF 
172186 . 172329) (FILES.WHENCHANGED 172331 . 172451)) (174554 181987 (RENAME 174564 . 175965) (
CHANGECALLERS 175967 . 181985)) (181988 229936 (SHOWDEF 181998 . 182791) (COPYDEF 182793 . 185267) (
GETDEF 185269 . 187545) (GETDEFCOM 187547 . 188513) (GETDEFCOM0 188515 . 189861) (GETDEFCURRENT 189863
 . 196283) (GETDEFERR 196285 . 197586) (GETDEFFROMFILE 197588 . 201868) (GETDEFSAVED 201870 . 202974) 
(PUTDEF 202976 . 203679) (EDITDEF 203681 . 204658) (DEFAULT.EDITDEF 204660 . 207496) (EDITDEF.FILES 
207498 . 207699) (LOADDEF 207701 . 207877) (DWIMDEF 207879 . 208733) (DELDEF 208735 . 211749) (
DELFROMLIST 211751 . 212255) (HASDEF 212257 . 218579) (GETFILEDEF 218581 . 219103) (SAVEDEF 219105 . 
220764) (UNSAVEDEF 220766 . 221662) (COMPAREDEFS 221664 . 224966) (COMPARE 224968 . 225672) (TYPESOF 
225674 . 229934)) (230003 235046 (FIXEDITDATE 230013 . 233516) (EDITDATE? 233518 . 235044)) (235465 
244051 (FILEPKGCOM 235475 . 240408) (FILEPKGTYPE 240410 . 244049)) (256084 270586 (FINDCALLERS 256094
 . 256609) (EDITCALLERS 256611 . 264219) (EDITFROMFILE 264221 . 269901) (FINDATS 269903 . 270175) (
LOOKIN 270177 . 270584)) (270587 272314 (SEPRCASE 270597 . 272312)) (272831 278373 (IMPORTFILE 272841
 . 273815) (IMPORTEVAL 273817 . 274697) (IMPORTFILESCAN 274699 . 275120) (CHECKIMPORTS 275122 . 276458
) (GATHEREXPORTS 276460 . 277783) (\DUMPEXPORTS 277785 . 278371)) (278711 280919 (CLEARFILEPKG 278721
 . 280917)))))
STOP
\ No newline at end of file
diff --git a/sources/FILEPKG.~8~ b/sources/FILEPKG.~8~
deleted file mode 100644
index 2c62c32a..00000000
--- a/sources/FILEPKG.~8~
+++ /dev/null
@@ -1,13 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 7-Mar-2020 14:24:19" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;8 284246 

      changes to%:  (VARS FILEPKGCOMS)

      previous date%: " 7-Mar-2020 14:09:52" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;7)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020 by Venue & Xerox Corporation.  All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")

(PRETTYCOMPRINT FILEPKGCOMS)

(RPAQQ FILEPKGCOMS 
       [(COMS                                                (* ; 
            "standard records for accessing file  package type/command parts.  Exported for PRETTY")
              (VARS FILEPKGTYPEPROPS)
              (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
              (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
              (INITRECORDS * FILEPKGRECORDS))
        [DECLARE%: EVAL@COMPILE DOCOPY 

               (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.")

               (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES 
                                       PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS
                                       PRETTYFLG))
                  (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES 
                                       NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS]
        (INITVARS (MSDATABASELST))
        [COMS 
              (* ;; "making, adding, listing, compiling files")

              (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES 
                   FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE
                   ADDFILE0 LISTFILES)
              (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
                     (FILELST)
                     (LOADEDFILELST)
                     (NOTLISTEDFILES)
                     (NOTCOMPILEDFILES)
                     (MAKEFILEFORMS)
                     (NILCOMS))
              (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% 
                              F ST STF (REC . RC)
                              (BREC . RC)
                              (TC . C)
                              (BC . C)
                              (TCOMPL . C)
                              (BCOMPL . C)))
              (INITVARS (MAKEFILEREMAKEFLG T)
                     (CLEANUPOPTIONS '(RC]
        (COMS 
              (* ;; "scanning file coms")

              (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS 
                   FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM
                   INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                   IFCDECLARE INFILEPAIRS INFILECOMSMACRO))
        (COMS 
              (* ;; "adding to a file")

              (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM 
                   ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM)
              (INITVARS (DEFAULTCOMHASFILEFLG))
              (ADDVARS (MARKASCHANGEDFNS))
              (FNS MERGEINSERT MERGEINSERT1)
              
              (* ;; "RMK: Changed INITVARS to VARS, so = addition works")

              (VARS [ADDTOFILEKEYLST (LIST '(%[ "" EXPLAINSTRING 
                                           "[ -- prettyprint the item to terminal and then ask again"
                                                NOECHOFLG T)
                                           '(= "" EXPLAINSTRING "= - same as previous response" 
                                               NOECHOFLG T)
                                           (LIST (CHARACTER (CHARCODE ^J))
                                                 ""
                                                 'EXPLAINSTRING 
                                                 "{line-feed} - same as previous response"
                                                 'NOECHOFLG T)
                                           '(%  " %
-" EXPLAINSTRING "{space} - no action" NOECHOFLG T
                                                )
                                           '(%] "Nowhere%
-" EXPLAINSTRING 
                                                "] - nowhere, item is marked as a dummy%
-" NOECHOFLG
                                                T)
                                           '[%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T 
                                                KEYLST (( "" CONFIRMFLG (%) %] %  %
-)
                                                           RETURN
                                                           (CDR ANSWER]
                                           '(@ "Near: " EXPLAINSTRING 
                                               "@ other-item   -- put the item near the other item" 
                                               NOECHOFLG T KEYLST (( "" CONFIRMFLG (%
-)
                                                                      RETURN ANSWER)))
                                           (LIST (CHARACTER (CHARCODE ^M))
                                                 ""
                                                 'RETURN
                                                 '% )
                                           '("" "File name: " EXPLAINSTRING "a file name" KEYLST
                                                (]
                    (LASTFILE)))
        (COMS 
              (* ;; "deleting an item from a file")

              (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE)
              (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
                 (MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
              (ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
        [COMS                                                (* ; 
                      "functions for doing things and marking them changed and auxiliary functions")
              (FNS SAVEPUT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
                                                     (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
              (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
              (ADDVARS (LISPXFNS (PUT . SAVEPUT)
                              (PUTPROP . SAVEPUT]
        (COMS                                                (* ; 
                                                  "sub-functions for file package commands & types")
              (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED 
                   MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS 
                   PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS 
                   FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS 
                   FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED)
              (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO)
                     (SYSPROPS PROPTYPE))
              (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT 
                    FILETYPE)
              (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS 
                    LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS 
                    PRETTYPRINTYPEMACROS USERMACROS))
        (COMS                                                (* ; 
                    "Define the commands below AFTER the various properties have been established.")
              (USERMACROS M))
        (COMS                                                (* ; "GETDEF methods")
              (FNS RENAME CHANGECALLERS)
              (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
                   GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF 
                   DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
              (INITVARS (WHEREIS.HASH)))
                                                             (* ; "Must come after PUTDEF")
        (FNS FIXEDITDATE EDITDATE?)
                                                             (* ; 
                                  "Edit date support for all kinds of definers (from PARC 6/10/92)")
        [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
              (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
        (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
        (COMS 
              (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")

              (FNS FILEPKGCOM FILEPKGTYPE)
              (PROP ARGNAMES FILEPKGCOM)
              (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
                     (FILEPKGTYPES FILEPKGCOMS))
              (FILEPKGCOMS FILEPKGCOMS)
              (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS
                     INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS
                     OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS))
        (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS)
                        (VARIABLES VARS CONSTANTS)))
        (INITVARS (SAVEDDEFS))
        (COMS                                                (* ; "EDITCALLERS")
              (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
              (FNS SEPRCASE)
              [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL]
              (INITVARS (SEPRCASEARRAYS)
                     (CLISPCASEARRAYS))
              (P (MOVD? 'INFILEP 'FINDFILE)
                                                             (* ; "or else from SPELLFILE"))
              (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
                             (NOLINKFNS LOADFROM)))
              (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS))
        (COMS                                                (* ; "EXPORT")
              (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS)
              (FILEPKGCOMS EXPORT)
              [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
                     (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"]
              (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM))
        (COMS                                                (* ; "for GAINSPACE")
              (FNS CLEARFILEPKG)
              [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                              ((Y "es")
                                               (N "o")
                                               (E . "verything")
                                               (F "ilemaps only%
-"]
              (GLOBALVARS SMASHPROPSLST1))
        (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT 
               DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 
               I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS 
               MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS 
               SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS)
        (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
                       (SPECVARS COMSNAME))
               (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
                      (NOLINKFNS . T)
                      (SPECVARS COMSNAME)
                      (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
               (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL 
                      INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                      IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
                      INFILECOMSPROP)
               (NIL MAKEFILE (LOCALVARS . T)
                    (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
               (ADDFILE ADDFILE ADDFILE0)
               (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
               (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
                    COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES 
                    EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM 
                    FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL 
                    LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS 
                    MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE 
                    POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
                    SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED 
                    UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS 
                                                 COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
                    (LOCALVARS . T))
               (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
               (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
                      GETDEFSAVED (RETFNS GETDEFCOM)
                      (NOLINKFNS . T)
                      (GLOBALVARS NOT-FOUNDTAG)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS 
                               MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP 
                               FILEPKGCOMPROPS PRETTYDEFMACROS)
                      (NLAML)
                      (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES])



(* ; "standard records for accessing file  package type/command parts.  Exported for PRETTY")


(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF CANFILEDEF FILEGETDEF))
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(DECLARE%: EVAL@COMPILE

(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
                                               (T (/REMPROP DATUM 'PRETTYTYPE]
                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
                                  (STANDARD [COND
                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
                                                                (OR (LISTP (GETTOPVAL 
                                                                                  'PRETTYDEFMACROS))
                                                                    (SETTOPVAL 'PRETTYDEFMACROS
                                                                           (LIST (LIST DATUM]
                                               (T (SETTOPVAL 'PRETTYDEFMACROS
                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
                                                                                'PRETTYDEFMACROS))
                                                                (GETTOPVAL 'PRETTYDEFMACROS]
                                         UNDOABLE
                                         (COND
                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
                                                                        (LIST (LIST DATUM]
                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
                                                                                   'PRETTYDEFMACROS))
                                                             (GETTOPVAL 'PRETTYDEFMACROS]
                                                             (* Not an atom record cause want 
                                                           REMPROP on NILs.)
                                                             (* NOTE%: PRETTCOM on PRETTY has 
                                                           open-coded access to the MACRO 
                                                           property.)
                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
                                       FILEPKGCONTENTS)))

(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
                                                           )
                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
                                                                              DATUM)))
                                                           (STANDARD (SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                      DATUM NEWVALUE)
                                                                                     )
                                                                            NEWVALUE)
                                                                  UNDOABLE
                                                                  (/SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                    DATUM NEWVALUE))
                                                                         NEWVALUE)))
                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
                                                                             DATUM)))
                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
                                                                               DATUM NEWVALUE))
                                                                       NEWVALUE)))
                                                    (ALLFIELDS NIL (/SETTOPVAL
                                                                    'PRETTYTYPELST
                                                                    (REMOVE (SEARCHPRETTYTYPELST
                                                                             DATUM)
                                                                           (GETTOPVAL 'PRETTYTYPELST]
                                                             (* NOTE%: PRETTYCOM on PRETTY has 
                                                           open-coded access to GETDEF property)
                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                                                                   (PUT X
                                                                                        'PROPTYPE
                                                                                        'FILEPKGCOMS]
                                         (ADDTOVAR PRETTYTYPELST))))

(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
                                                    UNDOABLE
                                                    (/PUTPROP DATUM 'FILE NEWVALUE])

(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))

(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
)

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST)
)

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(SEARCHPRETTYTYPELST
  [LAMBDA (TYPE FLG)                                     (* rmk%: " 3-JAN-82 22:55")
                                                             (* ; 
                                                           "access functions used by the records")
    (AND (LITATOM TYPE)
         (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X)
                                                               TYPE))
             (COND
                (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE
                                                                             'LST)
                                                                      TYPE NIL))
                                                      (GETTOPVAL 'PRETTYTYPELST]
                     (OR (LISTP (GETTOPVAL (CAR FLG)))
                         (/SETTOPVAL (CAR FLG)
                                NIL))
                     FLG])

(PRETTYDEFMACROS
  [NLAMBDA ARGS                                          (* lmm " 5-SEP-78 16:16")
                                                             (* ; 
                                                 "included so that old files will continue to load")
    (for X in ARGS collect (FILEPKGCOM (CAR X)
                                              'MACRO
                                              (CDR X])

(FILEPKGCOMPROPS
  [NLAMBDA PROPS
    (MAPC PROPS (FUNCTION (LAMBDA (Y)
                            (OR (MEMB Y SYSPROPS)
                                (SETQ SYSPROPS (CONS Y SYSPROPS)))
                            (PUT Y 'PROPTYPE 'FILEPKGCOMS])
)

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST)
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS 
                     *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG))

(CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS 
                     CLEANUPOPTIONS))
)

(RPAQ? MSDATABASELST )



(* ;; "making, adding, listing, compiling files")

(DEFINEQ

(CLEANUP
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (PROG (TEM1 TEM2 OPTIONS)
          (COND
             ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
              (SETQ OPTIONS (CAR FILES))
              (SETQ FILES (CDR FILES)))
             (T (SETQ OPTIONS CLEANUPOPTIONS)))
          (RETURN (APPEND (MAKEFILES OPTIONS FILES)
                         (COND
                            ((NOT (MEMB 'LIST OPTIONS))
                             NIL)
                            ((NULL FILES)
                             (LISTFILES))
                            ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES))
                                                             (* ; 
            "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.")
                             (APPLY 'LISTFILES TEM1)))
                         (COND
                            [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS]
                            ((NULL FILES)
                             (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES)
                                    (CDR TEM1))
                             TEM2)
                            ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES))
                             (COMPILEFILES0 TEM2 (CDR TEM1))
                             TEM2])

(COMPILEFILES
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (COND
       ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
        (COMPILEFILES0 (CDR FILES)
               (CAR FILES)))
       (T (COMPILEFILES0 FILES])

(COMPILEFILES0
  [LAMBDA (FILES OPTIONS)                                (* rmk%: "19-FEB-83 21:59")
    (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES)
       first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS))
                                (C (SETQ RCFLG NIL)
                                   (CDR OPTIONS))
                                (RC (CDR OPTIONS))
                                OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X)
                                                                           70 FILELST NIL X)
                                                                    (CAR X))
                                                        RCFLG OPTS X])

(CONTINUEDIT
  [LAMBDA (FILE)                                         (* bvm%: "30-Aug-86 15:09")
    (PROG (STREAM FL TEM FC ENV)
          (RESETLST
              [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT]
              (SETQ FILE (FULLNAME STREAM))
              (SETFILEPTR STREAM 0)
              (CL:MULTIPLE-VALUE-SETQ (ENV FC)
                     (\PARSE-FILE-HEADER STREAM 'RETURN)))
          (COND
             ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE]
              (LOADFROM FILE)                                (* ; 
                                                           "also calls addfile to notice the file.")
              ))
          (/replace FILECHANGES of FL with (FILECHANGES FC))
          [/replace FILEDATES of FL with
                                            (LIST (create FILEDATEPAIR
                                                         FILEDATE _ (CADR FC)
                                                         DATEFILENAME _ FILE)
                                                  (create FILEDATEPAIR
                                                         FILEDATE _
                                                         [CAR (SETQ TEM (CDR (MEMB 'date%: FC]
                                                         DATEFILENAME _ (CADR TEM]
          (RETURN FILE])

(MAKEFILE
  [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)           (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL;  LIST means list the FILE;  RC means RECOMPILE, C means COMPILEL;  --- for C AND RC assume ST unless next option is F.")

    (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS]
                           PRETTYFLG))
           (*PRINT-BASE* (if (EQ *PRINT-BASE* 8)
                             then 8
                           else                          (* ; "make sure radix is either 8 or 10, because all others don't read in like they print.  Maybe obsolete now with makefile environments")
                                 10))
           FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
          (DECLARE (CL:SPECIAL PRETTYFLG))
          (SETQ FILE (CAR Z))                                (* ; 
                                               "Necessary because FILE might have been misspelled.")
          (SETQ ROOTNAME (CADR Z))                           (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.")
          (SETQ FILEPROP (CDDR Z))
          (UPDATEFILES)                                  (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.")
          (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
          (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
          (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE))
      LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
                       (NULL FILEDATES))
              then                                       (* ; 
                   "File has never been loaded and never dumped i.e. user just set up COMS in core")
            elseif [OR (EQMEMB 'NEW OPTIONS)
                           (AND (NULL MAKEFILEREMAKEFLG)
                                (NOT (MEMB 'REMAKE OPTIONS]
              then (COND
                          ((AND (fetch LOADTYPE of FILEPROP)
                                (NEQ T (fetch LOADTYPE of FILEPROP)))
                           (LISPXPRIN2 FILE T T)
                           (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
                                           (LOADCOMP 
                                                  "the file was loaded for compilation purposes only")
                                           ((compiled Compiled COMPILED) 
                                                " -- only the compiled file has been loaded
")
                                           ((loadfns LOADFNS) 
                                                " -- only some of its symbolics have been loaded
")
                                           (SHOULDNT))
                                  T)
                           (COND
                              ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ")
                                    'Y)                      (* ; 
            "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.")
                               (GO OUT)))
                           (/replace LOADTYPE of FILEPROP with NIL)))
                    (SETQ SOURCEFILE NIL)
                    (SETQ REPRINTFNS NIL)
            elseif SOURCEFILE
              then                                       (* ; "source file given")
            elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T))
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
                                          (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE
                                                                              (fetch DATEFILENAME
                                                                                 of (CAR 
                                                                                            FILEDATES
                                                                                             ]
                                               (INFILEP SOURCEFILE)
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
              then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
                    (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
            elseif [AND (CDR FILEDATES)
                            [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
                            (EQUAL (FILEDATE SOURCEFILE)
                                   (fetch FILEDATE of (CADR FILEDATES]
              then 

                    (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.")

                    (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
                                         (fetch FILECHANGES of ROOTNAME)))
                    (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
            else (LISPXPRIN1 
                            '"can't find either the previous version or the original version of 
" T)
                  (LISPXPRIN2 FILE T T)
                  (LISPXPRIN1 '", so it will have to be written anew
" T)
                  (SETQ SOURCEFILE NIL)
                  (SETQ REPRINTFNS NIL)
                  (push OPTIONS 'NEW)
                  (SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
                  (GO LP0))
          (COND
             ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
                                          (LOADCOMP          (* ; 
                                                   "only loaded via LOADCOMP.  Need to do LOADFROM")
                                                    (LIST 'N SOURCEFILE "was loaded with LOADCOMP"
                                                          '- "LOADFROM it to obtain VARS/COMS"))
                                          (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%:
                                                                (fetch COMSNAME of FILEPROP))
                                                         (LIST 'Y "only compiled version of" ROOTNAME
                                                               
                                        "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions"
                                                               )))
                                          ((compiled loadfns) 
                                               (LIST 'N "Only some functions from" SOURCEFILE 
                                             "loaded via LOADFNS. Load all other expressions from it"
                                                     ))
                                          NIL)))
              (SELECTQ [ASKUSER DWIMWAIT (CAR Z)
                              (CDR Z)
                              '((Y "es
")
                                (N "o
")
                                (A "bort MAKEFILE
"]
                  (Y (SELECTQ (fetch LOADTYPE of FILEPROP)
                         (LOADCOMP                           (* ; 
                               "file was never actually loaded, just loadcomped.  thus no filecoms")
                                   (LOADFROM SOURCEFILE))
                         (Compiled 

                                 (* ;; "This is going to be a remake.  If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.")

                                   (LOADVARS 'DONTCOPY SOURCEFILE)
                                   (/replace LOADTYPE of FILEPROP with 'COMPILED)
                                                             (* ; "So wont have to be done again.")

                                 (* ;; "These are the only DECLARE:'s that are not also on the compiled file.  Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE:  Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)")

                                   )
                         ((loadfns compiled) 

                                 (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.")

                              (LOADVARS T SOURCEFILE))
                         NIL))
                  (A (GO OUT))
                  NIL)))
          (RESETLST
              [COND
                 ((MEMB 'NOCLISP OPTIONS)
                  (RESETSAVE PRETTYTRANFLG T))
                 ((MEMB 'CLISP%  OPTIONS)
                  (RESETSAVE PRETTYTRANFLG 'BOTH]
              (RESETSAVE %#UNDOSAVES)
              [COND
                 ((OR (MEMB 'CLISPIFY OPTIONS)
                      (MEMB 'CLISP OPTIONS))
                  (RESETSAVE CLISPIFYPRETTYFLG T))
                 ((OR (EQ FILETYPE 'CLISP)
                      (MEMB 'CLISP (LISTP FILETYPE)))
                  (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES]
              (for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
              (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
                                REPRINTFNS SOURCEFILE CHANGES)))
          (SETQ LASTFILE ROOTNAME)
          (/replace TOBEDUMPED of FILEPROP with NIL)
          (COND
             ((NOT (EQMEMB 'DON'TLIST FILETYPE))
              (pushnew NOTLISTEDFILES ROOTNAME)))
          (COND
             ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE))
              (pushnew NOTCOMPILEDFILES ROOTNAME)))
          [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL))
                                                 (SELECTQ OPT
                                                     (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                              (MAKEFILE1 FILE T (CDR TAIL))))
                                                     (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                             (MAKEFILE1 FILE NIL (CDR TAIL))))
                                                     (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
                                                                (APPLY 'LISTFILES (LIST FILE))))
                                                     (COND
                                                        ((MEMB OPT MAKEFILEOPTIONS))
                                                        ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL 
                                                                OPTIONS)
                                                         (GO $$LP))
                                                        (T (ERROR "Unrecognized MAKEFILE option" OPT]
          (RETURN FILE)
      OUT (RETURN (LIST FILE "-- MAKEFILE not performed."])

(FILECHANGES
  [LAMBDA (FILE TYPE)                                    (* bvm%: "30-Aug-86 15:08")

    (* ;; "If FILE is a list, it is assumed to be a file-created expressions;  otherwise, the filecreated expression is read from FILE.  If TYPE, returns the list of changed items of that type from the changes expression.  If TYPE=NIL, returns the whole list of typed change-lists")

    (PROG ([FCEXPR (OR (LISTP FILE)
                       (AND FILE (RESETLST
                                     (LET (OLDPTR STREAM)
                                          [if (SETQ STREAM (OPENP FILE 'INPUT))
                                              then (SETQ OLDPTR (GETFILEPTR STREAM))
                                                    (SETFILEPTR STREAM 0)
                                            else (RESETSAVE NIL (LIST 'CLOSEF
                                                                          (SETQ STREAM
                                                                           (OPENSTREAM FILE
                                                                                  'INPUT]
                                          (CL:MULTIPLE-VALUE-BIND (ENV FC)
                                                 (\PARSE-FILE-HEADER STREAM 'RETURN)
                                                 (if OLDPTR
                                                     then (SETFILEPTR STREAM OLDPTR))
                                                 FC)))]
           FNS CHANGES)
          (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR)))
                               (MEMB 'previous CHANGES)))
          [if (AND TYPE (NEQ TYPE 'FNS))
              then (RETURN (CDR (ASSOC TYPE CHANGES]
          (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM)))     (* ; 
                         "Old style changes expression listed FNS by name and other things by type")
          (RETURN (if TYPE
                      then                               (* ; "TYPE=FNS cause of test above.")
                            (NCONC FNS (CDR (ASSOC 'FNS CHANGES)))
                    elseif FNS
                      then (CONS (CONS 'FNS FNS)
                                     (SUBSET CHANGES (FUNCTION LISTP)))
                    else CHANGES])

(FILEPKG.MERGECHANGES
  [LAMBDA (C1 C2)                                        (* rmk%: "24-MAY-82 23:09")

    (* ;; "Merges 2 changes lists into a single one.  Treat LITATOM's as FNS, to accomodate old-style format on files.")

    (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND
                                                                                         E1)))
       in C2 do [COND
                           ((SETQ TEMP (ASSOC (CAR E2)
                                              VAL))
                            (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP))
                                           collect X)))
                           (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL])

(FILEPKG.CHANGEDFNS
  [LAMBDA (CHANGES)                                      (* rmk%: "20-MAY-82 22:00")

    (* ;; "Returns list of function names from a file-changes list.  Interprets old format (functions are atoms) and new format (with explicit type headers)")

    (CDR (ASSOC 'FNS CHANGES])

(MAKEFILE1
  [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES)            (* ; "Edited 29-Aug-89 11:46 by bvm")
    (PROG* ((ROOTNAME (ROOTFILENAME FILE))
            (COMPILER (COMPILE-FILE? ROOTNAME))
            GROUP)
           (COND
              ((AND (OR (EQ COMPILER 'BCOMPL)
                        (EQ COMPILER 'TCOMPL))
                    (NOT (FILEFNSLST ROOTNAME)))         (* ; 
                 "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.")
               (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
               (RETURN NIL)))
           (COND
              ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP))
                  suchthat (AND (NEQ X ROOTNAME)
                                    (OR (fetch TOBEDUMPED of (fetch FILEPROP of
                                                                                         X))
                                        (MEMB X OTHERFILES]

               (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled.  Wait.")

               (RETURN)))
           (LISPXPRIN1 '"
compiling " T)
           (LISPXPRINT (OR GROUP FILE)
                  T T)
           (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS)
                                                'ST)
                                            (EQ (CAR OPTIONS)
                                                'STF]
                             (FORGET-EXPRS? (EQ (CAR OPTIONS)
                                                'STF]
                            (SELECTQ COMPILER
                                ((FAKE-COMPILE-FILE)         (* ; 
                                               "The old CommonLispy interface to the ByteCompiler.")
                                     (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS
                                            (AND REDEFINE? (NOT FORGET-EXPRS?))))
                                ((CL:COMPILE-FILE)           (* ; "The new, improved (?) compiler")
                                     (CL:COMPILE-FILE FILE :LOAD (COND
                                                                    ((AND REDEFINE? (NOT 
                                                                                        FORGET-EXPRS?
                                                                                         ))
                                                                     :SAVE)
                                                                    (REDEFINE? T)
                                                                    (T NIL))))
                                ((TCOMPL BCOMPL)             (* ; "The old ByteCompiler")
                                     [IF (MEMB (CAR OPTIONS)
                                                   '(ST F S STF))
                                         THEN (LISPXUNREAD (LIST (CAR OPTIONS]
                                     [IF GROUP
                                         THEN 

                                               (* ;; 
                                   "File contained in FILEGROUP.  Therefore must be blockcompiled.")

                                               (IF RECOMPFLG
                                                   THEN (BRECOMPILE GROUP)
                                                 ELSE (BCOMPL GROUP))
                                       ELSEIF (EQ COMPILER 'TCOMPL)
                                         THEN (IF RECOMPFLG
                                                      THEN (RECOMPILE FILE)
                                                    ELSE (TCOMPL (LIST FILE)))
                                       ELSE (IF RECOMPFLG
                                                    THEN (BRECOMPILE FILE)
                                                  ELSE (BCOMPL (LIST FILE])
                                (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?...")))
                  T T])

(COMPILE-FILE?
  [LAMBDA (ROOTNAME)                                     (* ; "Edited 19-Jan-87 21:12 by Pavel")

(* ;;; "Which compiler should CLEANUP use?")

    (LET ((TYPE (GET ROOTNAME 'FILETYPE))
          (UNKNOWN NIL))
         (FOR X INSIDE TYPE DO (SELECTQ X
                                               ((TCOMPL :TCOMPL) 
                                                    (RETURN 'TCOMPL))
                                               ((BCOMPL :BCOMPL) 
                                                    (RETURN 'BCOMPL))
                                               ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) 
                                                    (RETURN 'FAKE-COMPILE-FILE))
                                               ((:COMPILE-FILE :XCL-COMPILE-FILE) 
                                                    (RETURN 'CL:COMPILE-FILE))
                                               ((CLISP) 
                                                    NIL)
                                               (SETQ UNKNOWN T))
            FINALLY (IF UNKNOWN
                            THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE
                                            ))
                  (RETURN *DEFAULT-CLEANUP-COMPILER*])

(MAKEFILES
  [LAMBDA (OPTIONS FILES)                                (* rmk%: "23-FEB-83 21:20")
    (RESETVARS (%#UNDOSAVES)                                 (* ; 
                                                   "Willing to save arbitrary amounts of undo info")
               (UPDATEFILES)
               [COND
                  ((NULL FILES)
                   (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE
                                                                         (COND
                                                                            ((NULL FLG)
                                                             (* ; "Gets printed the first time")
                                                                             
                                                                             '
                                        "****NOTE: the following are not contained on any file:
    ")
                                                                            (T '"    "]
                      do (SETQ FLG T) finally (AND FLG (ADDTOFILES?]
               (SETQ OPTIONS (MKLIST OPTIONS))
               (RETURN (for FILE inside (OR FILES FILELST)
                          when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP
                                                                          of (ROOTFILENAME FILE]
                          collect (LISPXPRIN2 FILE T T)
                                (LISPXPRIN1 '|...| T)
                                (PROG1 (MAKEFILE FILE OPTIONS)
                                       (LISPXTERPRI T])

(ADDFILE
  [LAMBDA (FILE LOADTYPE PRLST FCLST)                    (* bvm%: "29-Aug-86 12:22")

    (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           FLST VAL)
          [COND
             ((NOT FCLST)
              (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE)))
             [(NULL (CDR FCLST))                             (* ; "A simple symbolic file")
              (SETQ FCLST (CAR FCLST))
              (SETQ VAL (ADDFILE0 (COND
                                         ((LITATOM (CADR FCLST))
                                          (ROOTFILENAME (CADR FCLST)))
                                         (T ROOTNAME))
                               LOADTYPE FILE (CAR FCLST]
             (T 
                (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.")

                (SELECTQ LOADTYPE
                    ((T LOADFNS) 
                         (SETQ LOADTYPE 'Compiled))
                    (loadfns (SETQ LOADTYPE 'compiled))
                    (LOADCOMP                                (* ; 
                   "loadcomp on compiled file.  Don't notice since we don't know what its state is")
                              NIL)
                    (SHOULDNT))
                (for X in (CDR FCLST) when (LITATOM (CADR X))
                   do (push FLST (CADR X))
                         (OR (EQ LOADTYPE 'LOADCOMP)
                             (ADDFILE0 (ROOTFILENAME (CADR X))
                                    LOADTYPE
                                    (CADR X)
                                    (CAR X]
          (UPDATEFILES PRLST (OR FLST (LIST FILE)))
          [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES
                           when (AND (LITATOM TYPE)
                                         (SETQ CHANGED (fetch CHANGED of TYPE)))
                           do (/replace CHANGED of TYPE
                                     with (INTERSECTION (CDR (ASSOC TYPE PRLST))
                                                     CHANGED]
          (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS))
          (RETURN VAL])

(ADDFILE0
  [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT)               (* lmm "28-Nov-84 16:47")
    (PROG (COMS X FILEPROP FLG TEM)
      TOP (SETQ COMS (FILECOMS ROOTNAME))
          [COND
             ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME))
              (COND
                 ([AND LOADTYPE (FMEMB LOADTYPE
                                       (CDR (FMEMB (fetch LOADTYPE of FILEPROP)
                                                   '(LOADCOMP loadfns compiled Compiled LOADFNS 
                                                           COMPILED NIL T]
                  (/replace LOADTYPE of FILEPROP with LOADTYPE)

                  (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property.  'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file.  'Compiled' means all but DECLARE: expressions are in.  e.g. user does LOAD of a compiled file.  COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.  LOADFNS means everything in, e.g. user des LOADFROM symbolic file.  COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted.  NIL is a makefile when coms were set up in core.  T is full load of symbolic file.  The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.")

                  (* ;; "LOADCOMP means file was loadcomp'ed.  note that the actual structure is a tree, not a list, and the above is only an approximation.  if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc.  however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.")

                  (GO OUT))
                 (T (GO OUT1]
          (COND
             [(OR LOADTYPE (LISTP (GETTOPVAL COMS)))
              (SETQ FILEPROP (/replace FILEPROP of ROOTNAME
                                with (create FILEPROP
                                                COMSNAME _ COMS
                                                LOADTYPE _ LOADTYPE]
             (FLG (GO ERROR))
             ((AND DWIMFLG (EQ ROOTNAME FULLNAME)
                   (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T)))

              (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.")

              (SETQ FULLNAME ROOTNAME)
              (SETQ FLG T)                                   (* ; 
                                         "so wont try to spelling correct again if file isnt there")
              (GO TOP))
             (T (GO ERROR)))
      OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME
                               with (LIST (create FILEDATEPAIR
                                                     FILEDATE _ DAT
                                                     DATEFILENAME _ FULLNAME]
          (AND (EQ LOADTYPE T)
               (/replace TOBEDUMPED of FILEPROP with NIL))
      OUT1
          [COND
             ([AND (LISTP (GETTOPVAL COMS))
                   (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ; 
                                                          "coms wuld not be set up on a loadccomp.")
              (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST]
          (RETURN (COND
                     ((NULL LOADTYPE)                        (* ; "call from makefile.")
                      (CONS FULLNAME (CONS ROOTNAME FILEPROP)))
                     (T FILEPROP)))
      ERROR
          (ERROR FULLNAME "not file name." T])

(LISTFILES
  [NLAMBDA FILES                                         (* rmk%: " 3-Dec-84 08:58")
    (DECLARE (GLOBALVARS NOTLISTEDFILES))                (* ; "LISTFILES1 is machinedependent")
    (for FILE FULLNAME OPTIONS in (COND
                                             (FILES (SETQ FILES (NLAMBDA.ARGS FILES)))
                                             (T NOTLISTEDFILES))
       when (COND
                   ((LISTP FILE)
                    (SETQ OPTIONS (APPEND FILE OPTIONS))
                    NIL)
                   ((SETQ FULLNAME (FINDFILE FILE))
                    FULLNAME)
                   (T (printout T FILE " not found." T)
                      NIL)) collect [COND
                                           ((LISTFILES1 FULLNAME OPTIONS)
                                            (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
                                                                        NOTLISTEDFILES]
                                  FULLNAME])
)

(RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)

(RPAQ? FILELST )

(RPAQ? LOADEDFILELST )

(RPAQ? NOTLISTEDFILES )

(RPAQ? NOTCOMPILEDFILES )

(RPAQ? MAKEFILEFORMS )

(RPAQ? NILCOMS )

(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP%  F ST STF
                                 (REC . RC)
                                 (BREC . RC)
                                 (TC . C)
                                 (BC . C)
                                 (TCOMPL . C)
                                 (BCOMPL . C))

(RPAQ? MAKEFILEREMAKEFLG T)

(RPAQ? CLEANUPOPTIONS '(RC))



(* ;; "scanning file coms")

(DEFINEQ

(FILEPKGCHANGES
  [LAMBDA N                                              (* Pavel " 7-Oct-86 19:22")
    (COND
       [(EQ N 0)
        (PROG (TEM)
              (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X)
                                                                   (SETQ TEM (FILEPKGCHANGES
                                                                              X)))
                         collect (CONS X TEM]
       [(EQ (ARG N 1)
            T)
        (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES
                                                                                 X]
       [(EQ N 1)
        (COND
           [(LISTP (ARG N 1))
            (for X in (ARG N 1) when (FMEMB (CAR X)
                                                        FILEPKGTYPES)
               do (/replace CHANGED of (CAR X) with (CDR X]
           (T (for Y on (fetch CHANGED of (ARG N 1))
                 when [AND (CAR Y)
                               (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y)
                                                                                 Z]
                 collect (CAR Y]
       (T (/replace CHANGED of (ARG N 1) with (ARG N 2])

(GETFILEPKGTYPE
  [LAMBDA (TYPE ONLY NOERROR NAME)                       (* lmm "20-Nov-86 23:10")

    (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ")

    (COND
       [(LISTP TYPE)

        (* ;; " given a list of types, coerce them all or return NIL")

        (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME)
                                               (RETURN]
       ((EQ TYPE '?)

        (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ")

        (AND NAME (TYPESOF NAME)))
       [(AND (NEQ ONLY 'COMS)
             (OR (SELECTQ TYPE
                     (NIL 'FNS)
                     (T 'VARS)
                     NIL)
                 (for X in FILEPKGTYPES do (if (EQ TYPE X)
                                                           then 

                                                                 (* ;; "type matched exactly")

                                                                 (RETURN TYPE)
                                                         elseif (AND (LISTP X)
                                                                         (EQ TYPE (CAR X)))
                                                           then (RETURN (CDR X]
       [(AND (NEQ ONLY 'TYPE)
             (LITATOM TYPE)
             (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST))       (* ; "Prefer an exact match quickly")
                    ]
       [(AND (NEQ ONLY 'COMS)
             (LITATOM TYPE)
             (for X in FILEPKGTYPES bind NAME
                do (SETQ NAME (if (NLISTP X)
                                      then X
                                    else (CAR X))) 

                      (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization")

                      (AND (<= 0 (- (NCHARS NAME)
                                    (NCHARS TYPE))
                               1)
                           (STRPOS TYPE NAME)
                           (RETURN (if (EQ X NAME)
                                       then X
                                     else (CDR X]
       [(FIXSPELL TYPE NIL (SELECTQ ONLY
                               (TYPE FILEPKGTYPES)
                               (COMS FILEPKGCOMSPLST)
                               (UNION FILEPKGTYPES FILEPKGCOMSPLST]
       ((NOT NOERROR)
        (ERROR (SELECTQ ONLY
                   (TYPE "unrecognized manager definition type")
                   (COMS "unrecognized manager command")
                   "unrecognized manager definition-type/command")
               TYPE])

(MARKASCHANGED
  [LAMBDA (NAME TYPE REASON)                             (* ; "Edited 25-May-88 15:37 by drc:")
    (COND
       (FILEPKGFLG (SETQ REASON (SELECTQ REASON
                                    ((CLISP LOAD CHANGED DEFINED DELETED) 
                                         REASON)
                                    (NIL 'CHANGED)
                                    (T 'DEFINED)
                                    (ERROR "bad REASON in MARKASCHANGED" REASON)))
              (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (for FN inside (fetch WHENCHANGED of TYPE)
                 do (APPLY* FN NAME TYPE REASON))
              (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON))
              [COND
                 ((EQ REASON 'DELETED)
                  (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L)
                                                                                    NAME)
                     do (/RPLACA L NIL))                 (* ; 
                                                          "unmark as changed and remove from files")
                  (DELFROMFILES NAME TYPE))
                 (T (LET ((LST (push (fetch CHANGED of TYPE)
                                      NAME)))
                         (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST)
                                               LISPXHIST))   (* ; 
                             "UNDO by smashing with NIL;  makes calls to MARKASCHANGED independent")
                         ]
              NAME])

(FILECOMS
  [LAMBDA (FILE X)                                       (* rmk%: "19-FEB-83 13:55")
    (COND
       ((AND (NULL FILE)
             (NULL X))
        'NILCOMS)
       [(AND (OR (NULL X)
                 (EQ X 'COMS))
             (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE]
       (T (PACK* (NAMEFIELD FILE)
                 (OR X 'COMS])

(WHEREIS
  [LAMBDA (NAME TYPE FILES FN)                        (* ; "Edited 12-Jul-88 17:14 by MASINTER")

    (* ;; "T as a NAME has a special meaning to INFILECOMS?  so don't pass through.")

    (CL:UNLESS (EQ NAME T)
        (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES)
                                           FILELST)
                                      (FUNCTION (LAMBDA (FILE)
                                                  (INFILECOMS? NAME TYPE (FILECOMS FILE]
                               (AND (EQ FILES T)
                                    (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS)
                                    (LET ((FILES NIL))
                                         (for TY inside TYPE
                                            do (for FILE-NAME
                                                      in (XCL::HASH-FILE-WHERE-IS NAME
                                                                    (GETFILEPKGTYPE TYPE))
                                                      do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME))
                                                                    FILES)))
                                         (REVERSE FILES]
             (CL:IF FN
                 [MAPC IN-FILES (FUNCTION (LAMBDA (FILE)
                                            (APPLY* FN NAME FILE]
                 IN-FILES)))])

(SMASHFILECOMS
  [LAMBDA (FILE)                                         (* rmk%: "19-FEB-83 22:15")
    (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X)
       do (SETTOPVAL X 'NOBIND))
    FILE])

(FILEFNSLST
  [LAMBDA (FILE)                                         (* ; "Edited 14-Jun-90 19:30 by jds")
    (FILECOMSLST FILE '(FUNCTIONS FNS])

(FILECOMSLST
  [LAMBDA (FILE TYPE FLG)                                (* JonL "24-Jul-84 19:48")
                                                             (* ; 
                                                    "TYPE is coerced in the innards of INFILECOMS?")
    (COND
       ((EQ FLG 'UPDATE)
        (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE)
                    FLG)))
       (T (INFILECOMS? NIL TYPE (FILECOMS FILE)
                 FLG])

(UPDATEFILES
  [LAMBDA (PRLST FLST)                                   (* rmk%: "19-FEB-83 14:27")

    (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g.  LOAD, LOADFNS) involving the files in FLST began.")

    (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE))
       do (COND
                 ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE)))
                                                             (* ; 
                                                           "FILEPKGCHANGES eliminates duplicates")
                  (/replace CHANGED of TYPE with NIL))
                 (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES
                           (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST
                       first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) 

                             (* ;; "First check NIL=Nowhere.  LST:1 contains variables whose values are on the file literally.  These are `found' but not marked.  LST::1 contains all other items.")

                             (SETQ FOUND (NCONC (CAR LST)
                                                (CDR LST)
                                                FOUND))
                       do (SETQ PCHANGES (COND
                                                ((FMEMB (fetch DATEFILENAME
                                                           of (CAR (fetch FILEDATES
                                                                          of FILE)))
                                                        FLST)

                                 (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began.  Thus, by this intersection we only worry about items that were previously changed;  any items that were only changed during this operation are ignored.")

                                                 (INTERSECTION CHANGED PREVITEMS))
                                                (T CHANGED)))
                             [COND
                                ([AND PCHANGES [SETQ COMS (fetch COMSNAME
                                                             of (SETQ FILEPROP
                                                                     (LISTP (fetch FILEPROP
                                                                               of FILE]
                                      (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE]

                                 (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms")

                                 [COND
                                    ((CDR LST)               (* ; "CDR items must be distributed")
                                     [COND
                                        ((NULL (fetch TOBEDUMPED of FILEPROP))

                                         (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL")

                                         [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL
                                                                                   'NOTLISTEDFILES]
                                         (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE
                                                                              (GETTOPVAL 
                                                                                     '
                                                                                     NOTCOMPILEDFILES
                                                                                     ]
                                                             (* ; 
                                                   "Get the (possibly new) TYPE item list to smash")
                                     [COND
                                        [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED
                                                                        of FILEPROP]
                                        (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE]
                                                             (* ; 
                                                        "Now distribute items to the file property")
                                     (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP)
                                                                                   )
                                        do (/NCONC1 TYPEDPROP Y]
                                 (SETQ FOUND (NCONC (CAR LST)
                                                    (CDR LST)
                                                    FOUND] finally (/replace CHANGED
                                                                          of TYPE
                                                                          with (LDIFFERENCE
                                                                                    CHANGED FOUND])

(INFILECOMS?
  [LAMBDA (NAME TYPE COMS ONFILETYPE)                 (* ; "Edited 12-Jul-88 17:42 by MASINTER")

    (* ;; "Returns T if NAME is 'CONTAINED' in COMS.  If NAME is NIL, then value is a list of all of the functions contained in COMS.  If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.)  Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1.  while elements are the subset of NAME which are on the file in other case")

    (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS?  returns the dotted pair of (literals  . elements) where literals are those which are `literally' on the file (e.g.  (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")

    (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ")

    (PROG (VAL LITERALS ORIGFLG)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (SELECTQ ONFILETYPE
              (EDIT (SELECTQ TYPE
                        (FILEVARS (RETURN))
                        NIL))
              NIL)
          [COND
             ((LITATOM COMS)
              (SELECTQ TYPE
                  ((VARS FILEVARS)                           (* ; 
                                                           "the COMS of a file are also on it")
                       (INFILECOMSVAL COMS))
                  NIL)
              (SETQ COMS (EVALV COMS]
          (INFILECOMS COMS)
          (SETQ VAL (DREVERSE VAL))
          (RETURN (COND
                     ((EQ ONFILETYPE 'UPDATE)
                      (CONS LITERALS VAL))
                     (T VAL])

(INFILECOMTAIL
  [LAMBDA (COM FLG)                                   (* ; "Edited  2-Aug-88 02:15 by masinter")
    [SETQ COM (COND
                 ((EQ (CADR COM)
                      '*)
                  (COND
                     [(LITATOM (CADDR COM))
                      (LISTP (EVALV (CADDR COM]
                     (T [RESETVARS (DWIMLOADFNSFLG)
                                   (NLSETQ (SETQ COM (EVAL (CADDR COM]
                        COM)))
                 (T (CDR COM]
    (if (NOT FLG)
        then (for X in COM
                    do [if (AND (LISTP X)
                                        (EQ (CAR X)
                                            COMMENTFLG))
                               then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X)
                                                                        (OR (NLISTP X)
                                                                            (NEQ (CAR X)
                                                                                 COMMENTFLG]
                    finally (RETURN COM))
      else COM])

(INFILECOMS
  [LAMBDA (COMS)                                         (* rmk%: "19-FEB-83 22:17")
    (for X in COMS do (INFILECOM X])

(INFILECOM
  [LAMBDA (COM)                                       (* ; "Edited  2-Aug-88 02:27 by masinter")
    (COND
       [(NLISTP COM)
        (COND
           ((EQ TYPE 'VARS)
            (INFILECOMSVAL COM]
       ((EQ (CAR COM)
            COMMENTFLG)

        (* ;; 
"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
                                                             (* ; 
  "don't know why I should bother, but someone might want to know all of the comments on a file???")
        (COND
           ((EQ TYPE COMMENTFLG)
            (INFILECOMSVAL COM T)))
        NIL)
       (T
        (PROG ((COMNAME (CAR COM))
               (TAIL (CDR COM))
               CFN TEM)
              (COND
                 [[COND
                     ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
                      (SETQ TEM (APPLY* CFN COM (COND
                                                   ((AND (NULL ONFILETYPE)
                                                         (NOT (CL:SYMBOLP NAME)))
                                                             (* ; 
                                                "call from WHEREIS of a name which is not a symbol")
                                                    (LIST NAME))
                                                   (T NAME))
                                       TYPE ONFILETYPE)))
                     ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
                                                             (* ; "for compatability")
                      (SETQ TEM (APPLY* CFN COM TYPE NAME]
                  (COND
                     [(NLISTP TEM)
                      (COND
                         ((EQ TEM T)
                          (COND
                             ((OR (EQ NAME T)
                                  (NULL ONFILETYPE))
                              (RETFROM 'INFILECOMS? T]
                     (T (INFILECOMSVALS TEM]
                 ((LISTP TAIL)

                  (* ;; "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")

                  (SELECTQ COMNAME
                      ((PROP IFPROP) 
                           (SETQ TAIL (CDR TAIL)))
                      NIL)
                  [COND
                     ((EQ (CAR TAIL)
                          '*)
                      (COND
                         ((LITATOM (CADR TAIL))
                          (SELECTQ TYPE
                              ((VARS FILEVARS) 
                                   (INFILECOMSVAL (CADR TAIL)))
                              NIL))
                         ((AND (LISTP (CADR TAIL))
                               (EQ ONFILETYPE 'UPDATE)
                               (EQ TYPE 'VARS)
                               (EQ (CAADR TAIL)
                                   'PROGN)
                               (FMEMB (CAR (LAST (CADR TAIL)))
                                      NAME))
                          (SETQ VAL (CONS (CADR TAIL)
                                          VAL]
                  (SELECTQ COMNAME
                      ((COMS EXPORT) 
                           (INFILECOMS (INFILECOMTAIL COM T)))
                      (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM)
                                                           T)))
                      (DECLARE%:                             (* ; "skip over DECLARE: tags")
                                 [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM))
                                              (IFCDECLARE (INFILECOMTAIL COM)
                                                     (EQ TYPE 'DECLARE%:])
                      (ORIGINAL                              (* ; "dont expand macros")
                                (PROG ((ORIGFLG T))
                                      (INFILECOMS (INFILECOMTAIL COM T))))
                      ((PROP IFPROP)                         (* ; 
                                       "this currently does not handle `pseudo-types' of PROPNAMES")
                           (SELECTQ TYPE
                               (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM)
                                                              T)
                                             (CADR COM)))
                               (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
                                              (CADR COM)))
                               NIL))
                      (PROPS (RETURN (IFCPROPS COM)))
                      (MACROS (RETURN (SELECTQ TYPE
                                          (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T)
                                                        MACROPROPS))
                                          (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T)))
                                          NIL)))
                      (ALISTS                                (* ; 
                      "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")
                              (RETURN (SELECTQ TYPE
                                          (ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
                                          NIL)))
                      (P [RETURN (SELECTQ TYPE
                                     ((EXPRESSIONS P) 
                                          (INFILECOMSVALS (INFILECOMTAIL COM T)
                                                 T))
                                     (COND
                                        ((NULL ONFILETYPE)   (* ; "for WHEREIS and FILECOMSLST")
                                         (SELECTQ TYPE
                                             (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR))
                                             (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE))
                                             NIL])
                      ((ADDVARS APPENDVARS) 
                           (SELECTQ TYPE
                               (VARS [RETURN (AND (NULL ONFILETYPE)
                                                  (for X in (INFILECOMTAIL COM T)
                                                     do (INFILECOMSVAL (CAR X)
                                                                   T])
                               (ALISTS [RETURN (for X in (INFILECOMTAIL COM T)
                                                  when (EQMEMB 'ALIST (GETPROP (CAR X)
                                                                                 'VARTYPE))
                                                  do (for Z in (CDR X)
                                                            do (INFILECOMSVAL
                                                                    (LIST (CAR X)
                                                                          (CAR Z))
                                                                    T])
                               (OR (EQ TYPE COMNAME)
                                   (RETURN))))
                      ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) 
                           [RETURN (COND
                                      ((EQ TYPE 'EXPRESSIONS)
                                       (for X in (INFILECOMTAIL COM T)
                                          when (AND (LISTP X)
                                                        (NEQ (CAR X)
                                                             COMMENTFLG))
                                          do (INFILECOMSVAL (CONS 'SETQ X)
                                                        T)))
                                      ((OR (EQ TYPE 'VARS)
                                           (EQ TYPE COMNAME))(* ; 
                   "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
                                       (for X in (INFILECOMTAIL COM T)
                                          do (COND
                                                    ((LISTP X)
                                                     (AND (CAR X)
                                                          (NEQ (CAR X)
                                                               COMMENTFLG)
                                                          (INFILECOMSVAL (CAR X)
                                                                 T)))
                                                    (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS])
                      (DEFS [RETURN (for X in (INFILECOMTAIL COM T)
                                       when (EQ TYPE (CAR X)) do (INFILECOMSVALS
                                                                          (CDR X])
                      (FILES (RETURN))
                      NIL)

                  (* ;; "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")

                  (COND
                     ((EQ COMNAME TYPE)
                      (INFILECOMSVALS (INFILECOMTAIL COM T)))
                     [(AND (LISTP TYPE)
                           (FMEMB COMNAME TYPE))
                      (LET ((TYPE COMNAME))
                           (INFILECOMSVALS (INFILECOMTAIL COM T]
                     ((AND (OR (NULL CFN)
                               (AND (EQ CFN T)
                                    (NULL ONFILETYPE)))
                           (NULL ORIGFLG)
                           (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
                      (INFILECOMS (SUBPAIR (CAR TEM)
                                             (INFILECOMTAIL COM T)
                                             (CDR TEM])

(INFILECOMSVALS
  [LAMBDA (X FLG)                                     (* ; "Edited  2-Aug-88 02:21 by masinter")
    (for Y in X when (NOT (AND (LISTP Y)
                                           (EQ (CAR Y)
                                               COMMENTFLG))) do (INFILECOMSVAL Y FLG])

(INFILECOMSVAL
  [LAMBDA (X FLG)                                     (* ; "Edited 12-Jul-88 17:56 by MASINTER")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND (OR (NULL NAME)
                 (MEMBER X NAME))
             (COND
                (FLG (SETQ LITERALS (CONS X LITERALS)))
                (T (SETQ VAL (CONS X VAL]
       ((AND (EQ ONFILETYPE 'EDIT)
             FLG)                                            (* ; 
                                        "literals should not be edited as they are on the fileCOMS")
        NIL)
       ((EQ ONFILETYPE 'TYPESOF)
        (AND (COND
                ((LITATOM NAME)
                 (EQ NAME X))
                (T (EQUAL NAME X)))
             (CL:PUSHNEW TYPE VAL)))
       ([OR (EQ NAME T)
            (COND
               ((LITATOM NAME)
                (EQ NAME X))
               (T (EQUAL NAME X]
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS X VAL])

(INFILECOMSPROP
  [LAMBDA (AT PROP)                                      (* lmm "25-SEP-81 17:15")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND [OR (NULL NAME)
                 (find X in NAME suchthat (AND (EQ (CAR X)
                                                               AT)
                                                           (EQ (CADR X)
                                                               PROP]
             (SETQ VAL (CONS (LIST AT PROP)
                             VAL]
       ((OR (EQ NAME T)
            (AND (EQ (CAR NAME)
                     AT)
                 (EQ (CADR NAME)
                     PROP)))
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS (LIST AT PROP)
                        VAL])

(IFCPROPS
  [LAMBDA (COM)                                          (* bvm%: " 2-Dec-83 14:24")

(* ;;; "Examine a PROPS com for objects of specified TYPE")

    (SELECTQ TYPE
        (PROPS                                               (* ; 
                                       "the PROPS command can actually take (PROPNAME at1 at2 ...)")
               (INFILEPAIRS (INFILECOMTAIL COM)))
        (PROP                                                (* ; 
                                                "return the atoms which have any properties at all")
              (for PAIR in (INFILECOMTAIL COM) do (for ATNAME
                                                                     inside (CAR PAIR)
                                                                     do (INFILECOMSVAL ATNAME
                                                                                   ))))
        (MACROS                                              (* ; "only MACRO properties")
                (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR)
                                                                           (CDR PAIR))))
        NIL])

(IFCEXPRTYPE
  [LAMBDA (COM FN)                                       (* ; "Edited  6-Apr-87 20:20 by Pavel")

(* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN")

    (for SUBCOM in (INFILECOMTAIL COM)
       when (AND (EQ (CAR SUBCOM)
                         FN)
                     (EQ (CAR (LISTP (CADR SUBCOM)))
                         'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM))
                                                T])

(IFCPROPSCAN
  [LAMBDA (ATOMS PROPNAMES)                           (* ; "Edited  2-Aug-88 02:20 by masinter")

(* ;;; 
"Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES")

    (for AT in ATOMS WHEN (LITATOM AT) unless [COND
                                                                 [(EQ ONFILETYPE 'UPDATE)
                                                                  (COND
                                                                     (NAME (NOT (ASSOC AT NAME]
                                                                 ((LISTP NAME)
                                                                  (NEQ AT (CAR NAME]
       do (COND
                 ((EQ PROPNAMES 'ALL)
                  (for PROP in (GETPROPLIST AT) by (CDDR PROP)
                     when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP)))
                 (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])

(IFCDECLARE
  [LAMBDA (TAIL WANTDECLARE)                          (* ; "Edited  8-Jun-90 18:11 by teruuchi")
    (PROG ((TAIL TAIL))
      LP  (COND
             ((LISTP TAIL)
              [SELECTQ (CAR TAIL)
                  ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                       [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
                                                                 (CADR TAIL]
                       (SETQ TAIL (CDR TAIL)))
                  (DONTEVAL@LOAD [COND
                                    ((OR (\STKSCAN 'DOFILESLOAD)
                                         (\STKSCAN 'LOAD))
                                                  (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"")
                                     (RETURN))
                                    (WANTDECLARE (INFILECOMSVAL (CAR TAIL])
                  (COMPILERVARS (RETURN))
                  (COND
                     [(FMEMB (CAR TAIL)
                             DECLARETAGSLST)
                      (COND
                         (WANTDECLARE (INFILECOMSVAL (CAR TAIL]
                     (T (INFILECOM (CAR TAIL]
              (SETQ TAIL (CDR TAIL))
              (GO LP])

(INFILEPAIRS
  [LAMBDA (LST)                                          (* lmm " 4-DEC-78 09:51")
    (for LL in LST do (for X inside (CAR LL)
                                     do (for Y inside (CDR LL)
                                               do (INFILECOMSVAL (LIST X Y])

(INFILECOMSMACRO
  [LAMBDA (ATS PROPS)                                    (* lmm "28-SEP-78 18:35")

    (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.  --- Normally (e.g.  for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom.  However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties")

    (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE)
                                               (EVERY (PROPNAMES AT)
                                                      (FUNCTION (LAMBDA (X)
                                                                  (OR (NOT (FMEMB X MACROPROPS))
                                                                      (EQMEMB X PROPS]
                                           [SOME MACROPROPS (FUNCTION (LAMBDA (PROP)
                                                                        (EQMEMB PROP PROPS]
                                           (INFILECOMSVAL AT])
)



(* ;; "adding to a file")

(DEFINEQ

(FILES?
  [LAMBDA NIL                                            (* bvm%: "27-Oct-86 18:14")

(* ;;; 
"Display each file needing dumping, etc.  For files needing dumping, display details of why.")

    (UPDATEFILES)
    (LET (FILES CHANGES PRINTED)
         (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED
                                                                of (LISTP (fetch FILEPROP
                                                                                 of FILE]
            do (if (NOT PRINTED)
                       then (LISPXPRIN1 "To be dumped:
" T)
                             (SETQ PRINTED T))
                  (LISPXPRIN2 FILE T)
                  (LISPXPRIN1 " ...changes to " T)
                  [for CH in CHANGES bind TB
                     do (COND
                               ((LISTP CH)
                                [COND
                                   (TB (LISPXTAB TB NIL T))
                                   (T (SETQ TB (POSITION T]
                                (LISPXPRIN2 (CAR CH)
                                       T)
                                (FILES?PRINTLST (CDR CH)))
                               (T                            (* ; "old style")
                                  (LISPXPRIN2 CH T)
                                  (LISPXSPACES 1 T]
                  (LISPXTERPRI T))
         (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED "    plus "))
            do (SETQ FLG T) finally (if FLG
                                                then (OR PRINTED (LISPXPRIN1 "...to be dumped.  "
                                                                            T))
                                                      (ADDTOFILES?)))
         (if (SETQ FILES NOTCOMPILEDFILES)
             then (FILES?PRINTLST FILES "To be compiled: ")
                   (LISPXTERPRI T))
         (if (SETQ FILES NOTLISTEDFILES)
             then (FILES?PRINTLST FILES "To be listed: ")
                   (LISPXTERPRI T))
         (CL:VALUES])

(FILES?1
  [LAMBDA (TYPE FIRST)                                   (* bvm%: "27-Oct-86 18:17")

    (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.")

    (LET (STR LST)
         (COND
            ([AND (LITATOM TYPE)
                  (SETQ STR (fetch DESCRIPTION of TYPE))
                  (LISTP (SETQ LST (fetch CHANGED of TYPE]
             (AND FIRST (LISPXPRIN1 FIRST T))
             (LISPXPRIN1 '"the " T)
             (LISPXPRIN1 STR T)
             (FILES?PRINTLST LST)
             (LISPXTERPRI T)
             T])

(FILES?PRINTLST
  [LAMBDA (LST STR)                                      (* bvm%: "27-Oct-86 18:15")

    (* ;; "Print elements of LST separated by commas and indenting new lines a bunch.  If MAPRINT had a left margin arg, this would be simpler.")

    (MAPRINT LST T (OR STR ": ")
           NIL ", " [FUNCTION (LAMBDA (STR)
                                (COND
                                   ((> (+ (POSITION T)
                                          (NCHARS STR T T)
                                          3)
                                       (LINELENGTH NIL T))
                                    (LISPXTERPRI T)
                                    (LISPXPRIN1 "         " T)))
                                (LISPXPRIN2 STR T T]
           T])

(ADDTOFILES?
  [LAMBDA (NOASKSTR)                                     (* ; "Edited 21-Aug-91 10:13 by jds")

    (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says")

    (ERSETQ
     (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS]

      (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g.  changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES")

           [COND
              (NOASKSTR (PRIN1 NOASKSTR T))
              (T (DOBE)
                 (SETQ BUFS (READP T))
                 (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go")
                                 '((Y "es
")
                                   (N "o
")
                                   (%] "Nowhere
" EXPLAINSTRING "] - nowhere, all items will be marked as dummy
" NOECHOFLG T))
                                 T)
                     (N (RETURN))
                     (%] (for TYPE in FILEPKGTYPES
                            do (for NAME in (fetch (FILEPKGTYPE CHANGED)
                                                           of TYPE)
                                      do (ADDTOFILE NAME TYPE NIL)))
                         (RETURN))
                     NIL)                                    (* ; 
                              "if there was type-ahead BEFORE the askuser, then don't allow it now")
                 (COND
                    (BUFS (SETQ BUFS (COND
                                        ((READP T)
                                         (LINBUF)
                                         (SYSBUF)
                                         (SETQ BUFS (CLBUFS NIL T READBUF]
           [for TYPE STR LST in FILEPKGTYPES
              when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
                            (LISTP (SETQ LST (COND
                                                ((EQ TYPE 'VARS)
                                                 VARSCHANGES)
                                                (T (fetch (FILEPKGTYPE CHANGED) of TYPE]
              do
              (printout T "(" STR ")" T)
              (for NAME TEM FILE in LST when NAME
                 do
                 (PROG NIL
                   LP  (PRIN2 NAME T)
                       (SPACES 2 T)

                  (* ;; "if user typed ahead before entering addtofiles??  then dont allow typeahead here, because it will justgobble his earlier typeahead.")

                       (SELECTQ (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T))
                           (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)

                                 (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer")

                                              (DOBE)))
                               (GO LP))
                           (%] (SETQ FILE))
                           (%                                (* ; "space.  means no action")
                               (RETURN))
                           (%
 (PRINT (OR (SETQ FILE LASTFILE)
            'Nowhere)
        T))
                           (SETQ FILE TEM))
                       (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
                                         (SETQ PLACE (WHATIS FILE NIL TYPE))
                                         [COND
                                            ((LITATOM PLACE) (* ; "file name")
                                             (SETQ FILE PLACE)
                                             (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                                                        NAME TYPE NEAR LISTNAME)
                                                 (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                          (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.")

                                             )
                                            ((EQ (CAR PLACE)
                                                 'Near%:)
                                             (SETQ NEAR (CADR PLACE))
                                             (COND
                                                ([SOME FILELST (FUNCTION (LAMBDA (FL)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           FL))
                                                                            NAME TYPE NEAR LISTNAME]
                                                 (PRINT (LIST 'on FILE)
                                                        T T))
                                                (T (PRINT (LIST (CADR PLACE)
                                                                'not
                                                                'found)
                                                          T T)
                                                   (ERROR!)))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE)))
                                            ([OR [UNDONLSETQ (PROGN (SAVESET
                                                                     (SETQ LISTNAME (CAR PLACE))
                                                                     (MERGEINSERT
                                                                      NAME
                                                                      (LISTP (GETTOPVAL LISTNAME))
                                                                      T)
                                                                     T
                                                                     'NOPRINT)
                                                                    (OR (SETQ FILE
                                                                         (CAR (WHEREIS NAME TYPE
                                                                                     FILELST)))
                                                                        (ERROR!]
                                                 (SOME FILELST (FUNCTION (LAMBDA (X)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           X))
                                                                            NAME TYPE NEAR LISTNAME]
                                             (PRIN1 "  value is filed on " T)
                                             (PRINT FILE T T)
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                 (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed")

                                             )
                                            (T (PRIN1 "    put list " T)
                                               (PRIN2 (CAR PLACE)
                                                      T T)
                                               (SETQ FILE
                                                (WHATIS (ASKUSER NIL NIL " on file: "
                                                                   '(("" "" EXPLAINSTRING 
                                                                         "a file name" KEYLST ()))
                                                                   T)
                                                       'FILE))
                                               (SAVESET (CAR PLACE)
                                                      (MERGEINSERT NAME
                                                             (LISTP (GETTOPVAL (CAR PLACE)))
                                                             T)
                                                      T
                                                      'NOPRINT)

                                     (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.")

                                               (ADDNEWCOM (FILECOMS FILE)
                                                      NAME TYPE (CAR PLACE)
                                                      FILE)
                                               (for F in (fetch WHENFILED of TYPE)
                                                  do (for I in (GETTOPVAL (CAR PLACE))
                                                            do (APPLY* F I TYPE FILE]
                                         (AND FILE (ADDFILE FILE))
                                         (SETQ LASTFILE PLACE)))
                           (GO LP]
           (AND BUFS (BKBUFS BUFS))
           (UPDATEFILES])

(ADDTOFILE
  [LAMBDA (NAME TYPE FILE NEAR LISTNAME)                 (* lmm "21-Nov-84 11:43")
                                                             (* ; "adds NAME to the file FILE")
    (PROG (TEM COMSNAME)
          [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T)
                         (COND
                            ((FMEMB TYPE FILELST)
                             (GETFILEPKGTYPE (swap TYPE FILE)))
                            (T (GETFILEPKGTYPE TYPE]
          (SETQ FILE (WHATIS FILE 'FILE))
          (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                     NAME TYPE NEAR LISTNAME)
              (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
          (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))
          (AND FILE (NOT (FMEMB FILE FILELST))
               (ADDFILE FILE))
          (RETURN FILE])

(WHATIS
  [LAMBDA (USERINPUT ONLY)                               (* lmm "28-Nov-84 16:49")

    (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble;  if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable")

    (PROG (TEM UCASE)
          (RETURN (COND
                     ((NULL USERINPUT)                       (* ; "nowhere")
                      NIL)
                     [(LISTP USERINPUT)
                      (COND
                         (ONLY (ERROR!))
                         (T (SELECTQ (CAR USERINPUT)
                                ((@ Near%:) 
                                     (CONS 'Near%: (CDR USERINPUT)))
                                (WHATIS (CAR USERINPUT)
                                       'LIST]
                     ([AND (NEQ ONLY 'LIST)
                           (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT)))
                                      FILELST)
                               (LISTP (GETTOPVAL (FILECOMS UCASE)))
                               (SETQ TEM (FIXSPELL UCASE NIL FILELST T]
                      TEM)
                     ((AND (NEQ ONLY 'FILE)
                           (LISTP (GETTOPVAL USERINPUT)))
                      (LIST USERINPUT))
                     ((AND (NEQ ONLY 'LIST)
                           (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE)
                                      NIL T)
                               'Y))
                      UCASE)
                     ((AND (NEQ ONLY 'FILE)
                           (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT)
                                      NIL T)
                               'Y))
                      (LIST USERINPUT))
                     (T                                      (* ; "none of above")
                        (ERROR!])

(ADDTOCOMS
  [LAMBDA (COMS NAME TYPE NEAR LISTNAME)                 (* rmk%: "10-JUN-82 22:53")

    (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms);  return NIL if unsuccessful.  If LISTNAME is given, then only insert by adding to LISTNAME.  If NEAR is given, only insert near it")

    (COND
       ((NULL COMS)
        NIL)
       [(LITATOM COMS)                                       (* ; 
      "given a name of a command;  rebind COMSNAME to current variable and try to add to its value")
        (OR [PROG ((COMSNAME COMS))
                  (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME))
                                 NAME TYPE NEAR (AND (NEQ COMS LISTNAME)
                                                     LISTNAME]
            (AND (EQ COMS LISTNAME)
                 (ADDNEWCOM COMS NAME TYPE]
       (T (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (for TAIL on COMS do (COND
                                              [(LISTP (CAR TAIL))
                                               (COND
                                                  ((ADDTOCOM (CAR TAIL)
                                                          NAME TYPE NEAR LISTNAME)
                                                   (RETURN T]
                                              (T (SELECTQ (CAR TAIL)
                                                     ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                                                          (SETQ TAIL (CDR TAIL)))
                                                     NIL])

(ADDTOCOM
  [LAMBDA (COM NAME TYPE NEAR LISTNAME)                  (* ; "Edited  2-May-87 19:04 by Pavel")
                                                             (* ; 
                        "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful")
    (PROG (TEM)
          (COND
             ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM]
              (RETURN)))
          [COND
             ((SETQ TEM (fetch ADD of (CAR COM)))
              (RETURN (COND
                         ((OR (NULL LISTNAME)
                              (INFILECOMS? LISTNAME 'FILEVARS (LIST COM)))
                          (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR))
                               (MARKASCHANGED COMSNAME 'VARS))
                          TEM]
          (RETURN
           (SELECTQ (CAR COM)
               (FNS (AND (EQ TYPE 'FNS)
                         (ADDTOCOM1 COM NAME NEAR LISTNAME)))
               ((VARS INITVARS) 
                    (COND
                       ((OR (EQ (CAR COM)
                                'VARS)
                            NEAR LISTNAME)                   (* ; 
                                  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.")
                        (SELECTQ TYPE
                            (EXPRESSIONS (COND
                                            ((EQ (CAR NAME)
                                                 'SETQ)
                                             (ADDTOCOM1 COM (CDR NAME)
                                                    NEAR LISTNAME))))
                            (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME))
                            NIL))))
               (COMS (ADDTOCOMS (COND
                                       [(EQ (CADR COM)
                                            '*)
                                        (COND
                                           ((LITATOM (CADDR COM))
                                            (CADDR COM))
                                           (T (RETURN]
                                       (T (CDR COM)))
                            NAME TYPE NEAR LISTNAME))
               (DECLARE%: (AND (OR LISTNAME NEAR)
                               (ADDTOCOMS (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     ((LITATOM (CADDR COM))
                                                      (CADDR COM))
                                                     (T (RETURN]
                                                 (T (CDR COM)))
                                      NAME TYPE NEAR LISTNAME)))
               (CL:EVAL-WHEN (AND (OR LISTNAME NEAR)
                                  (ADDTOCOMS (COND
                                                    [(EQ (CL:THIRD COM)
                                                         '*)
                                                     (COND
                                                        ((LITATOM (CL:FOURTH COM))
                                                         (CL:FOURTH COM))
                                                        (T (RETURN]
                                                    (T (CDDR COM)))
                                         NAME TYPE NEAR LISTNAME)))
               ((PROP IFPROP) 
                    (SELECTQ TYPE
                        (PROPS (COND
                                  ((EQ (CADR COM)
                                       (CADR NAME))
                                   (ADDTOCOM1 (CDR COM)
                                          (CAR NAME)
                                          NEAR LISTNAME))
                                  ((AND (EQ (CAR NAME)
                                            (CADDR COM))
                                        (NULL (CDDDR COM)))
                                   [/RPLACA (CDR COM)
                                          (UNION (MKLIST (CDR NAME))
                                                 (MKLIST (CADR COM]
                                   (MARKASCHANGED COMSNAME 'VARS)
                                   T)))
                        (MACROS (COND
                                   ([AND (for PROP inside (CADR COM)
                                            always (EQMEMB PROP MACROPROPS))
                                         (for PROP in MACROPROPS
                                            always (OR (EQMEMB PROP (CADR COM))
                                                           (NOT (GETPROP NAME PROP]

                                    (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")

                                    (ADDTOCOM1 (CDR COM)
                                           NAME NEAR LISTNAME))))
                        NIL))
               ((PROPS ALISTS) 
                    (AND (EQ TYPE (CAR COM))
                         (ADDTOCOM1
                          COM
                          (/NCONC1 (OR [ASSOC (CAR NAME)
                                              (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     [(LITATOM (CADDR COM))
                                                      (AND (OR (NULL LISTNAME)
                                                               (EQ (CADDR COM)
                                                                   LISTNAME))
                                                           (GETTOPVAL (CADDR COM]
                                                     (T (RETURN]
                                                 (T (CDR COM]
                                       (LIST (CAR NAME)))
                                 (CADR NAME))
                          NEAR LISTNAME)))
               (P (COND
                     ((AND (EQ TYPE 'EXPRESSIONS)
                           (NEQ (CAR NAME)
                                'SETQ))
                      (ADDTOCOM1 COM NAME NEAR LISTNAME))))
               (AND (EQ (CAR COM)
                        TYPE)
                    (ADDTOCOM1 COM NAME NEAR LISTNAME])

(ADDTOCOM1
  [LAMBDA (COM NAME NEAR LISTNAME)                       (* rmk%: " 3-JAN-82 22:53")
    (COND
       [(EQ (CADR COM)
            '*)                                              (* ; "add to list name")
        (AND [COND
                (LISTNAME (EQ (CADDR COM)
                              LISTNAME))
                (T (LITATOM (CADDR COM]
             (SAVESET (CADDR COM)
                    [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM]
                           (COND
                              ((AND NEAR (SETQ NEAR (MEMBER NEAR COM)))
                               (/RPLACD NEAR (CONS NAME (CDR NEAR)))
                               COM)
                              (T (MERGEINSERT NAME COM T]
                    T
                    'NOPRINT]
       ((NULL LISTNAME)                                      (* ; "add to standard com")
        [AND (NOT (MEMBER NAME (CDR COM)))
             (COND
                [(SETQ NEAR (MEMBER NEAR COM))
                 (/RPLACD NEAR (CONS NAME (CDR NEAR]
                (T (/RPLACD COM (MERGEINSERT NAME (CDR COM]
        (MARKASCHANGED COMSNAME 'VARS)
        T])

(ADDNEWCOM
  [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE)             (* rmk%: " 3-JAN-82 22:53")

    (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE.  --- if LISTNAME is given, then use it as the listname")

    (PROG (NEWCOM OLDCOM TAIL)
          (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE))
          [COND
             ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME)))
              (RETURN (SAVESET COMSNAME (LIST NEWCOM)
                             T
                             'NOPRINT]
      LP  [COND
             ((OR (NLISTP (SETQ OLDCOM (CAR TAIL)))
                  (SELECTQ (CAR OLDCOM)
                      ((LOCALVARS SPECVARS BLOCKS) 
                           T)
                      (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM)))
                      NIL))
              (/ATTACH NEWCOM TAIL))
             ((LISTP (CDR TAIL))
              (SETQ TAIL (CDR TAIL))
              (GO LP))
             (T (/RPLACD TAIL (LIST NEWCOM]
          (MARKASCHANGED COMSNAME 'VARS])

(MAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* ; "Edited  8-Apr-87 14:55 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    (PROG (TEM)

     (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname")

          (AND (LISTP NAME)
               (SETQ NAME (COPY NAME)))
          (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE))
                           (APPLY* TEM NAME TYPE LISTNAME FILE))
                      (SELECTQ TYPE
                          (PROPS [AND (NULL LISTNAME)
                                      (CONS 'PROP (CONS (COND
                                                           ((AND (LISTP (CDR NAME))
                                                                 (NULL (CDDR NAME)))
                                                            (CADR NAME))
                                                           (T (CDR NAME)))
                                                        (OR (LISTP (CAR NAME))
                                                            (LIST (CAR NAME])
                          (EXPRESSIONS [COND
                                          ((EQ (CAR NAME)
                                               'SETQ)
                                           (MAKENEWCOM (CDR NAME)
                                                  'VARS LISTNAME FILE))
                                          (T (CONS 'P (COND
                                                         (LISTNAME (LIST '* LISTNAME))
                                                         (T (LIST NAME])
                          NIL)
                      (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE])

(DEFAULTMAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* lmm "20-OCT-82 22:48")
    (COND
       ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST)
                 (fetch MACRO of TYPE)
                 (fetch GETDEF of TYPE)))
        (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION
                                                                            of TYPE)
                                                                         TYPE)
               T))
       ((NULL DEFAULTCOMHASFILEFLG)                          (* ; "disable FOOFNS FOOVARS junk")
        (LIST TYPE NAME))
       ((EQ FILE T)                                          (* ; 
                                                           "FILE=T only when called from SHOWDEF")
        (LIST TYPE NAME))
       ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE))
                                      (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME))
                                             T)
                                      T
                                      'NOPRINT]              (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items")
        (LIST TYPE '* LISTNAME))
       (T (LIST TYPE NAME])
)

(RPAQ? DEFAULTCOMHASFILEFLG )

(ADDTOVAR MARKASCHANGEDFNS )
(DEFINEQ

(MERGEINSERT
  [LAMBDA (NEW LST ONEFLG)                               (* lmm "30-Jun-86 18:11")

    (* ;; "searches LST to find the most reasonable place to insert NEW.  Does nothing if ONEFLG is T and NEW is already a member of LST")

    (COND
       ((AND ONEFLG (MEMBER NEW LST))
        LST)
       ((LISTP NEW)
        (/NCONC1 LST NEW))
       (T (PROG ((N 0)
                 LST1 PLACE TEM)
                (SETQ LST1 LST)
            LP  

           (* ;; "finds the function with the longest leading common substring.  The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.")

                (COND
                   ((NULL LST1)
                    (GO OUT))
                   ((OR (LISTP (CAR LST1))
                        (SETQ TEM (STRPOS (CAR LST1)
                                         NEW 1 NIL T T)))

                    (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE")

                    (SETQ PLACE LST1)
                    (GO OUT))
                   ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1)
                                                NEW))
                           N)
                    (SETQ N TEM)
                    (SETQ PLACE LST1)))
                (SETQ LST1 (CDR LST1))
                (GO LP)
            OUT (SETQ TEM (CAR PLACE))
                (OR [SOME (OR PLACE LST)
                          (FUNCTION (LAMBDA (X LST)
                                      (COND
                                         ([OR (ALPHORDER NEW X)
                                              (AND PLACE (NOT (ALPHORDER TEM X]

                                 (* ;; "for example, if the FNS list is something like (...  FOO FOO1 ...) where the ...  may or may not be in order, e.g.  (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.")

                                          (/ATTACH NEW LST))
                                         (T (SETQ TEM X)
                                            NIL]
                    (SETQ LST (/NCONC1 LST NEW)))
                (RETURN LST])

(MERGEINSERT1
  [LAMBDA (X Y)                                          (* rmk%: "24-MAY-82 00:05")

    (* ;; "value is the number of leading characters of X and Y that agree.")

    (PROG ((N 1)
           C1 C2)
      LP  [COND
             ((OR (NULL (SETQ C1 (NTHCHARCODE X N)))
                  (NULL (SETQ C2 (NTHCHARCODE Y N)))
                  (NEQ C1 C2))
              (RETURN (SUB1 N]
          (SETQ N (ADD1 N))
          (GO LP])
)



(* ;; "RMK: Changed INITVARS to VARS, so = addition works")


(RPAQ ADDTOFILEKEYLST [LIST '(%[ "" EXPLAINSTRING 
                                     "[ -- prettyprint the item to terminal and then ask again" 
                                     NOECHOFLG T)
                                '(= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T)
                                (LIST (CHARACTER (CHARCODE ^J))
                                      ""
                                      'EXPLAINSTRING "{line-feed} - same as previous response"
                                      'NOECHOFLG T)
                                '(%  " %
-" EXPLAINSTRING "{space} - no action" NOECHOFLG T)
                                '(%] "Nowhere%
-" EXPLAINSTRING 
                                     "] - nowhere, item is marked as a dummy%
-" NOECHOFLG T)
                                '[%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
                                     (( "" CONFIRMFLG (%) %] %  %
-)
                                         RETURN
                                         (CDR ANSWER]
                                '(@ "Near: " EXPLAINSTRING 
                                    "@ other-item   -- put the item near the other item" NOECHOFLG T
                                    KEYLST (( "" CONFIRMFLG (%
-)
                                               RETURN ANSWER)))
                                (LIST (CHARACTER (CHARCODE ^M))
                                      ""
                                      'RETURN
                                      '% )
                                '("" "File name: " EXPLAINSTRING "a file name" KEYLST (])

(RPAQQ LASTFILE NIL)



(* ;; "deleting an item from a file")

(DEFINEQ

(DELFROMFILES
  [LAMBDA (NAME TYPE FILES)                              (* rmk%: " 6-MAR-82 13:16")

    (* ;; "Eliminates NAME as an item of type TYPE in COMS.")

    (PROG (COMS)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (RETURN (for FILE inside (OR FILES FILELST)
                     when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE))
                                            NAME TYPE)
                                  (COND
                                     ((INFILECOMS? NAME TYPE COMS)
                                      (printout T "(could not delete " NAME " from " FILE ")" T))))
                     collect (for FN in (fetch WHENUNFILED of TYPE)
                                    do (APPLY* FN NAME TYPE FILE))
                           FILE])

(DELFROMCOMS
  [LAMBDA (COMS NAME TYPE)                               (* bvm%: " 1-Oct-86 22:02")

    (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list).  Returns T if it does anything")

    (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.")

    (COND
       [(LITATOM COMS)
        (LET ((COMSNAME COMS))
             (DECLARE (SPECVARS COMS))
             (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME)))
                  (DELFROMCOMS COMS NAME TYPE]
       (T (PROG (DONE)
                (SETQ TYPE (GETFILEPKGTYPE TYPE))
            LP  (COND
                   ((NLISTP COMS)
                    (RETURN DONE)))
                [COND
                   ((LISTP (CAR COMS))
                    (SELECTQ (DELFROMCOM (CAR COMS)
                                    NAME TYPE)
                        (ALL (/RPLNODE2 COMS (CDR COMS))
                             (SETQQ DONE ALL)
                             (GO LP))
                        (NIL)
                        (SETQ DONE T)))
                   (T (SELECTQ (CAR COMS)
                          ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                               (SETQ COMS (CDR COMS)))
                          (COND
                             ((AND (EQ TYPE 'VARS)
                                   (EQ NAME (CAR COMS)))
                              (/RPLNODE2 COMS (CDR COMS))
                              (SETQ DONE T)
                              (GO LP]
                (SETQ COMS (CDR COMS))
                (GO LP])

(DELFROMCOM
  [LAMBDA (COM NAME TYPE)                                (* ; "Edited  2-May-87 19:02 by Pavel")
                                                             (* ; "Tries to delete NAME from COM")
    (PROG (TEM VAR NEW)
          (COND
             ((SETQ TEM (fetch DELETE of (CAR COM)))
              (AND (SETQ TEM (APPLY* TEM COM NAME TYPE))
                   (MARKASCHANGED COMSNAME 'VARS))
              (RETURN TEM)))
          (RETURN (SELECTQ (CAR COM)
                      ((DECLARE%: COMS) 
                           (DELFROMCOMS (COND
                                               [(EQ (CADR COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CADDR COM))
                                                    (CADDR COM))
                                                   (T (RETURN]
                                               (T (CDR COM)))
                                  NAME TYPE))
                      ((CL:EVAL-WHEN) 
                           (DELFROMCOMS (COND
                                               [(EQ (CL:THIRD COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CL:FOURTH COM))
                                                    (CL:FOURTH COM))
                                                   (T (RETURN]
                                               (T (CDDR COM)))
                                  NAME TYPE))
                      ((ALISTS PROPS) 
                           (AND (EQ TYPE (CAR COM))
                                (COND
                                   ((EQ (CADR COM)
                                        '*)
                                    (COND
                                       ([AND (LITATOM (SETQ VAR (CADDR COM)))
                                             (SETQ TEM (ASSOC (CAR NAME)
                                                              (GETTOPVAL VAR)))
                                             (NEQ (CDR TEM)
                                                  (SETQ TEM (REMOVEITEM (CADR NAME)
                                                                   (CDR TEM]
                                        (SAVESET VAR TEM T 'NOPRINT)
                                        T)))
                                   ([AND [CDR (SETQ TEM (ASSOC (CAR NAME)
                                                               (CDR COM]
                                         (NEQ (CDR TEM)
                                              (SETQ NEW (REMOVEITEM (CADR NAME)
                                                               (CDR TEM]
                                    (/RPLACD TEM NEW)
                                    (MARKASCHANGED COMSNAME 'VARS)
                                    T))))
                      (BLOCKS 
                              (* ;; "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")

                              [AND (EQ TYPE 'FNS)
                                   (for BLOCK in (INFILECOMTAIL COM T)
                                      do (AND (MEMB NAME BLOCK)
                                                  (/DREMOVE NAME BLOCK))
                                            (for X in BLOCK
                                               when (AND (LISTP X)
                                                             (MEMB NAME (CDR X)))
                                               do (/RPLACD X (REMOVE NAME (CDR X])
                      ((PROP IFPROP) 
                           [SELECTQ TYPE
                               (PROPS (RETURN (COND
                                                 ((EQ (CADR COM)
                                                      (CADR NAME))
                                                  (DELFROMCOM1 (CDR COM)
                                                         (CAR NAME)))
                                                 ((AND (EQMEMB (CADR NAME)
                                                              (CADR COM))
                                                       [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM]
                                                       (EQ (CAR TEM)
                                                           (CAR NAME)))
                                                  [/RPLACA (CDR COM)
                                                         (REMOVE (CADR NAME)
                                                                (MKLIST (CADR COM]
                                                  (MARKASCHANGED COMSNAME 'VARS)
                                                  T))))
                               (COND
                                  ([for PROP inside (CADR COM)
                                      always (EQ TYPE (GETPROP PROP 'PROPTYPE]
                                   (DELFROMCOM1 (CDR COM)
                                          NAME])
                      ((RECORDS INITRECORDS SYSRECORDS) 
                           (AND (EQ TYPE 'RECORDS)
                                (DELFROMCOM1 COM NAME)))
                      (P (AND (EQ TYPE 'EXPRESSIONS)
                              (DELFROMCOM1 COM NAME)))
                      ((VARS INITVARS) 
                           (AND (EQ TYPE 'VARS)
                                (DELFROMCOM1 COM NAME T)))
                      (AND (EQ TYPE (CAR COM))
                           (DELFROMCOM1 COM NAME])

(DELFROMCOM1
  [LAMBDA (COM NAME FLG)                                 (* rmk%: "10-JUN-82 22:44")

    (* ;; 
  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed")

    (LET (TEM VAL)
         (COND
            ((EQ (CADR COM)
                 '*)
             (COND
                ([AND (LITATOM (SETQ TEM (CADDR COM)))
                      (NEQ (SETQ VAL (GETTOPVAL TEM))
                           (SETQ VAL (REMOVEITEM NAME VAL FLG]
                 (SAVESET TEM VAL T 'NOPRINT)
                 T)))
            ((NEQ (CDR COM)
                  (SETQ TEM (REMOVEITEM NAME (CDR COM)
                                   FLG)))
             (/RPLACD COM TEM)
             (MARKASCHANGED COMSNAME 'VARS)
             T])

(REMOVEITEM
  [LAMBDA (X LST FLG)                                    (* ; "Edited 25-May-88 17:52 by drc:")
                                                             (* lmm "10-FEB-78 17:29")

    (* ;; 
  "returns a subset of LST with X deleted;  if FLG is set, also remove elements whose CAR is X")

    (COND
       [[OR (MEMBER X LST)
            (AND FLG (SOME LST (FUNCTION (LAMBDA (Y)
                                           (EQUAL (CAR (LISTP Y))
                                                  X]
        (SUBSET LST (FUNCTION (LAMBDA (Y)
                                (AND (NOT (EQUAL Y X))
                                     (OR (NOT FLG)
                                         (NLISTP Y)
                                         (NOT (EQUAL (CAR Y)
                                                     X]
       (T LST])

(MOVETOFILE
  [LAMBDA (TOFILE NAME TYPE FROMFILE)                    (* rmk%: "18-OCT-79 19:51")
                                                             (* ; "To move items between files")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    [COND
       ((OR (EQ TYPE 'FNS)
            FROMFILE)                                        (* ; 
       "FNS definition can reside on file if LOADFNS was done.  This guarantees that it is loaded.")
        (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM]
    (AND (EQ TYPE 'FNS)
         (MARKASCHANGED NAME TYPE))                      (* ; 
                                                   "FNS won't get dumped unless they are `changed'")
    (DELFROMFILES NAME TYPE FROMFILE)
    (ADDTOFILE NAME TYPE TOFILE])
)

(MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)

(MOVD? 'MOVETOFILE 'MOVEITEM NIL T)

(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)



(* ; "functions for doing things and marking them changed and auxiliary functions")

(DEFINEQ

(SAVEPUT
  [LAMBDA (ATM PROP VAL)                                 (* lmm " 7-May-84 16:56")

    (* ;; "analogous to SAVESET but also marks changed property lists;  LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT")

    [COND
       ((NOT (LITATOM ATM))
        (ERRORX (LIST 14 ATM]
    (PROG ((X (GETPROPLIST ATM))
           X0 TEM OLDFLG)
      LOOP
          (COND
             ((NLISTP X)
              (COND
                 ((AND (NULL X)
                       X0)                                   (* ; 
                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")
                  (SETQ TEM (LIST PROP VAL))
                  (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                        LISPXHIST))
                  (FRPLACD (CDR X0)
                         TEM)
                  (GO RET)))

              (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")

              )
             ((NLISTP (CDR X))

              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning.")

              )
             [(EQ (CAR X)
                  PROP)
              (SETQ OLDFLG (NEQ (EQUALN (CADR X)
                                       VAL 400)
                                T))                          (* ; "i.e. it probably changed")
              (/RPLACA (CDR X)
                     VAL)
              (COND
                 ((NOT OLDFLG)
                  (GO RET1))
                 (T (OR (EQ DFNFLG T)
                        (LISPXPRINT (LIST 'new PROP 'property 'for ATM)
                               T T))
                    (GO RET]
             (T (SETQ X (CDDR (SETQ X0 X)))
                (GO LOOP)))
          [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM]
          (SETPROPLIST ATM TEM)
          (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                LISPXHIST))
      RET (MARKASCHANGED (LIST ATM PROP)
                 'PROPS
                 (NOT OLDFLG))
      RET1
          (AND ADDSPELLFLG (ADDSPELL ATM 0))
          (RETURN VAL])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
    (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT))
)
(DEFINEQ

(UNMARKASCHANGED
  [LAMBDA (NAME TYPE)                                    (* JonL "24-Jul-84 19:59")

    (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties.  Value is name if anything is done")

    (PROG (ANYFLG)
          (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE
                                                                          TYPE
                                                                          'TYPE]
             while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL)
                                                               (SETQ ANYFLG T))
          [for F TAIL PROP TYPEDPROP in FILELST
             when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP
                                                    (ASSOC TYPE (fetch TOBEDUMPED
                                                                   of (SETQ PROP
                                                                           (fetch FILEPROP
                                                                              of F]
             do (SETQ ANYFLG T)
                   (COND
                      ((SETQ TAIL (REMOVE (CAR TAIL)
                                         (CDR TYPEDPROP)))
                       (/RPLACD TYPEDPROP TAIL))
                      (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP
                                                                              (fetch TOBEDUMPED
                                                                                 of PROP]
          (RETURN (AND ANYFLG NAME])

(PREEDITFN
  [LAMBDA (ATM TYPE EDITCHANGES)                         (* rmk%: "18-FEB-82 21:49")
                                                             (* ; 
                                           "EDITL is advised to call this before editing something")
    (AND FILEPKGFLG (SELECTQ TYPE
                        (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                   (CONS))
                                                            CLISPARRAY))
                                      (for X in (GETPROPLIST ATM)
                                         do (OR (NLISTP X)
                                                    (GETHASH X CLISPARRAY)
                                                    (PUTHASH X (CONS (CAR X)
                                                                     (CDR X))
                                                           CLISPARRAY]

                                 (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made")

                                 [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS)
                                                      EDITCHANGES
                                                      (APPEND (GETPROPLIST ATM])
                        (VARS [COND
                                 ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE))
                                  [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                    (CONS))
                                                             CLISPARRAY))
                                       (for X in (EVALV ATM)
                                          do (OR (NLISTP X)
                                                     (GETHASH X CLISPARRAY)
                                                     (PUTHASH X (CONS (CAR X)
                                                                      (CDR X))
                                                            CLISPARRAY]
                                  (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS)
                                                       EDITCHANGES
                                                       (for X in (EVALV ATM)
                                                          collect (CAR X])
                        NIL])

(POSTEDITPROPS
  [LAMBDA (EDITCHANGES OLDPROPS)                         (* rmk%: "18-FEB-82 21:50")
                                                             (* ; "was RESETSAVE'd from PREEDITFN")
    (PROG (OV FOUNDCHANGE)
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP)
                 when (for OLDPROP on OLDPROPS by (CDDR OLDPROP)
                             do (COND
                                       ((EQ (CAR OLDPROP)
                                            (CAR NEWPROP))   (* ; "Found the property")
                                        [AND (EQ (CADR OLDPROP)
                                                 (CADR NEWPROP))
                                             (COND
                                                ((NLISTP (CADR OLDPROP))
                                                             (* ; "value is same")
                                                 (RETURN))
                                                ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP)
                                                                                 CLISPARRAY))
                                                      (EQ (CAADR NEWPROP)
                                                          (CAR OV))
                                                      (EQ (CDADR NEWPROP)
                                                          (CDR OV)))
                                                 (PUTHASH (CADR NEWPROP)
                                                        NIL CLISPARRAY)
                                                             (* ; 
                                         "value has been edited (CLISPARRAY translation went away)")
                                                 (RETURN]
                                        (RETURN T))) finally 
                                                             (* ; "didn't find the property")
                                                           (RETURN T))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 (CAR NEWPROP))
                               'PROPS NIL)
                       (SETQ FOUNDCHANGE T))
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])

(POSTEDITALISTS
  [LAMBDA (EDITCHANGES OLDTOKENS)                        (* rmk%: " 4-JAN-82 10:14")
    (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES]
                                                             (* ; 
                                                           "called after an ALIST has been edited")
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 X)
                               'ALISTS NIL)
                       (SETQ FOUNDCHANGE T))
              [for NEWENTRY in NEWENTRIES
                 do (COND
                           ([AND (LISTP NEWENTRY)
                                 (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY))
                                           (EQ (CAR NEWENTRY)
                                               (CAR OV))
                                           (EQ (CDR NEWENTRY)
                                               (CDR OV]
                            (PUTHASH NEWENTRY NIL CLISPARRAY)
                            (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                     (CAR NEWENTRY))
                                   'ALISTS NIL)
                            (SETQ FOUNDCHANGE T]
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])
)

(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
                       (PUTPROP . SAVEPUT))



(* ; "sub-functions for file package commands & types")

(DEFINEQ

(ALISTS.GETDEF
  [LAMBDA (NAME TYPE OPTIONS)                            (* Pavel " 7-Oct-86 17:24")
    (AND (LISTP NAME)
         (CL:SYMBOLP (CAR NAME))
         (LET [(ASSOCIATION (ASSOC (CADR NAME)
                                   (GETTOPVAL (CAR NAME]
              (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME)
                                     ASSOCIATION])

(ALISTS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm "16-OCT-78 20:02")
                                                             (* ; 
                                          "called by MARKASCHANGED when an ALIST entry has changed")
    (PROG [(VARTYPE (GETPROP (CAR NAME)
                           'VARTYPE]
          (AND (LISTP VARTYPE)
               (EQ (CAR VARTYPE)
                   'ALIST)
               (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME)
                                              (CADR VARTYPE)
                                              NEWFLG])

(CLEARCLISPARRAY
  [LAMBDA (NAME TYPE REASON)
    (DECLARE (SPECVARS NAME TYPE REASON))            (* lmm "14-Aug-84 15:03")
    (AND CLISPARRAY (MAPHASH CLISPARRAY (COND
                                           [(EQ TYPE 'I.S.OPRS)
                                            (FUNCTION (LAMBDA (TRAN FORM)
                                                        (AND (MEMB NAME FORM)
                                                             (PUTHASH FORM NIL CLISPARRAY]
                                           (T                (* ; "MACRO changed")
                                              (FUNCTION (LAMBDA (TRAN FORM)
                                                          (COND
                                                             ((OR (EQ NAME (CAR FORM))
                                                                  (EQ (CAR (GETPROP (CAR FORM)
                                                                                  'CLISPWORD))
                                                                      'CHANGETRAN))
                                                              (PUTHASH FORM NIL CLISPARRAY])

(EXPRESSIONS.WHENCHANGED
  [LAMBDA (EXPR)                                         (* ; "Edited  6-Apr-87 20:21 by Pavel")
    (SELECTQ (CAR EXPR)
        ((SETQ SETQQ) 
             (UNMARKASCHANGED (CADR EXPR)
                    'VARS))
        ((PROGN PROG) 
             (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X)))
        NIL])

(MAKEALISTCOMS
  [NLAMBDA X                                             (* rmk%: "14-OCT-83 13:34")

    (* ;; "make command to dump prettydefmacros")

    (LIST
     (CONS 'ADDVARS
           (for PR in X
              join (for ALISTNAME inside (CAR PR)
                          collect (CONS ALISTNAME
                                            (for ATNAME inside (CDR PR) bind ENTRY
                                               when (SETQ ENTRY
                                                         (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME))
                                                             (PROGN (LISPXPRINT (LIST 'no ATNAME
                                                                                      'entry
                                                                                      'on ALISTNAME)
                                                                           T T)
                                                                    NIL))) collect ENTRY])

(MAKEFILESCOMS
  [NLAMBDA FILES                                         (* JonL "12-FEB-83 19:02")

    (* ;; "This scans the command just to warn the user about any errors.  Must match up with the big SELECTQ in FILESLOAD NIL")

    [for FILE in FILES
       do
       (OR
        (LITATOM FILE)
        (while (LISTP FILE)
           do (SELECTQ (CAR (OR (LISTP FILE)
                                    (RETURN)))
                      ((LOADCOMP LOADFROM))
                      (FROM (pop FILE)
                            (if (OR (EQ (CAR FILE)
                                            'VALUEOF)
                                        (if (AND (EQ (CAR FILE)
                                                         'VALUE)
                                                     (EQ (CADR FILE)
                                                         'OF))
                                            then (pop FILE)))
                                then (pop FILE)))
                      ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR))
                      (OR (FMEMB (CAR FILE)
                                 LOADOPTIONS)
                          (PRINT (CONS (CAR FILE)
                                       '(-- unrecognized FILES option))
                                 T)))
                 (pop FILE]
    (CONS 'FILESLOAD FILES])

(MAKELISPXMACROSCOMS
  [NLAMBDA X                                             (* lmm " 5-SEP-78 23:15")
    (PROG (TEM TEM2)
          (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                   LISPXHISTORYMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXHISTORYMACROS TEM)))
                                                       (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                          LISPXMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXMACROS TEM]
                        (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z LISPXCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2]
                                          (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z HISTORYCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2])

(MAKEPROPSCOMS
  [NLAMBDA X                                             (* lmm "26-FEB-78 17:10")

    (* ;; "make command to dump PROPS")

    (for PAIR in X collect (CONS 'PROP (CONS (COND
                                                            ((AND (LISTP (CDR PAIR))
                                                                  (NULL (CDDR PAIR)))
                                                             (CADR PAIR))
                                                            (T (CDR PAIR)))
                                                         (OR (LISTP (CAR PAIR))
                                                             (LIST (CAR PAIR])

(MAKEUSERMACROSCOMS
  [NLAMBDA X                                             (* rmk%: " 3-JAN-82 23:20")
    (PROG (TEM)
          [COND
             [X (for Y in X
                   do (OR (FASSOC Y USERMACROS)
                              (FASSOC Y EDITMACROS)
                              (LISPXPRINT (CONS Y '(-- no entry on USERMACROS))
                                     T T]
             (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR))
                               X]
          (RETURN (LIST (CONS 'ADDVARS
                              (NCONC (for VAR in '(USERMACROS EDITMACROS)
                                        when (SETQ TEM (for Y in (GETTOPVAL VAR)
                                                              when (FMEMB (CAR Y)
                                                                              X) collect Y))
                                        collect (CONS VAR TEM))
                                     (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS 
                                                                 DONTSAVEHISTORYCOMS)
                                        when [SETQ TEM
                                                  (SUBSET (GETTOPVAL LST)
                                                         (FUNCTION (LAMBDA (Y)
                                                                     (OR (FMEMB Y X)
                                                                         (AND (LISTP Y)
                                                                              (FMEMB (CAR Y)
                                                                                     X]
                                        collect (CONS LST TEM])

(PROPS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm " 7-SEP-78 22:08")
    (PROG [(PROPTYPE (GETPROP (CADR NAME)
                            'PROPTYPE]
          (COND
             [PROPTYPE (RETFROM 'MARKASCHANGED (COND
                                                  ((NEQ PROPTYPE 'IGNORE)
                                                   (MARKASCHANGED (CAR NAME)
                                                          PROPTYPE NEWFLG]
             (T (SELECTQ (CADR NAME)
                    (CLISPWORD (CLEARCLISPARRAY (CAR NAME)))
                    NIL])

(FILEGETDEF.LISPXMACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:12")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (EQ FIRST 'ADDTOVAR)
                                                                   (MEMB SECOND '(LISPXMACROS 
                                                                                        LISPXCOMS))
                                                                   T]
                when (SELECTQ (CADR X)
                             (LISPXMACROS                    (* ; 
                      "Rebuild the expressions cause there might be other elements in the ADDTOVAR")
                                          (AND (SETQ X (ASSOC NAME (CDDR X)))
                                               (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X))))
                             (LISPXCOMS [COND
                                           ((MEMB NAME (CDDR X))
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME)))
                                           ((SETQ X (ASSOC NAME (CDDR X)))
                                                             (* ; "For synonym pairs")
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X])
                             NIL) collect X])

(FILEGETDEF.ALISTS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'ADDTOVAR)
                                                          (EQ SECOND (CAR NAME]
       when (SETQ X (ASSOC (CADR NAME)
                               (CDDR X))) collect X
       finally (RETURN (COND
                              ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.RECORDS
  [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND)            (* lmm "26-Jun-86 15:56")
    (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                              (AND (MEMB FIRST CLISPRECORDTYPES)
                                                   (OR (EQ SECOND NAME)
                                                       (AND (MEMB SECOND '(%( %[))
                                                            (PROGN (RATOM)
                                                                   (RATOM)
                                                                   (RATOM)
                                                                   (EQ NAME (RATOM]
         (if (EQ (CAAR VAL)
                     'NOT-FOUND%:)
             then NOTFOUND
           elseif (CDR VAL)
             then (CONS 'PROGN VAL)
           else (CAR VAL])

(FILEGETDEF.PROPS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'PUTPROPS)
                                                          (EQ SECOND (CAR NAME]
       join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL)
                                                                              (CADR NAME))
                   join (LIST (CAR TAIL)
                                  (CADR TAIL)))
       finally (RETURN (COND
                              ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.MACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "28-May-86 09:51")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (FMEMB FIRST '(PUTPROPS DEFMACRO))
                                                                   (EQ SECOND NAME]
                join (if (EQ (CAR X)
                                     'DEFMACRO)
                             then (LIST X)
                           else (for TAIL on (CDDR X) by (CDDR TAIL)
                                       when (FMEMB (CAR TAIL)
                                                       MACROPROPS) collect (LIST 'PUTPROPS
                                                                                     (CADR X)
                                                                                     (CAR TAIL)
                                                                                     (CADR TAIL])

(FILEGETDEF.VARS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:14")
    (for X in (LOADFNS NIL SOURCE 'GETDEF NAME)
       do (SELECTQ (CAR X)
                  ((RPAQQ SETQQ) 
                       (RETURN (CADDR X)))
                  ((RPAQ SETQ RPAQ?) 
                       (RETURN (EVAL (CADDR X))))
                  NIL) finally (RETURN 'NOBIND])

(FILEGETDEF.FNS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: "29-Aug-86 22:30")
    (LET (MAP ENV)
         (COND
            [(AND (EQMEMB 'FAST OPTIONS)
                  (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
                                (GET-ENVIRONMENT-AND-FILEMAP SOURCE))
                         MAP))
             (for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME
                                                                                      (CDDR PAIR]
                do [OR (OPENP SOURCE)
                           (RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
                                                                             'OLD]
                      (SETFILEPTR SOURCE MAPLOC)
                      (RETURN (WITH-READER-ENVIRONMENT ENV
                                  [COND
                                     ((EQMEMB 'ARGLIST OPTIONS)
                                      (RATOM SOURCE)
                                      (READ SOURCE)
                                      (RATOM SOURCE)
                                      (LIST (READ SOURCE)
                                            (READ SOURCE)))
                                     (T (CADR (READ SOURCE])]
            (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])

(FILEPKGCOMS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 11:29")
    (PROG (COM TYP)
          [SELECTQ (CAR (LISTP DEFINITION))
              (COM (SETQ COM (CDR DEFINITION)))
              (TYPE (SETQ TYP (CDR DEFINITION)))
              (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION)))
                     (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION]

     (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE")

          (for I in COM by (CDDR I) do (SELECTQ I
                                                           ((ADD DELETE MACRO CONTENTS CONTAIN COM))
                                                           (ERROR I 
                                                                  "not file package command property"
                                                                  )))
                                                             (* ; 
                                                   "COM merely adds to spelling list, for builtins")
          [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS)
                                             (LISTGET COM 'CONTAIN]
                                                             (* ; "Until CONTAIN is de-documented.")
          (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP
                                                                         (LISTGET COM PROP)))
          [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS)
                                                           (SELECTQ I
                                                               ((DESCRIPTION TYPE))
                                                               (ERROR I 
                                                             "not file package type/command property"
                                                                      ]
                                                             (* ; 
                                                  "TYPE merely adds to spelling list, for builtins")
          (for PROP in (UNION '(DESCRIPTION TYPE)
                                      FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP
                                                                      (LISTGET TYP PROP])

(FILES.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 17:13")
    (PROGN (PUTDEF (FILECOMS NAME)
                  'VARS
                  (CAR DEFINITION)
                  REASON)                                    (* ; "DEFINE THE COMS")
           (ADDFILE NAME)                                (* ; 
                                                           "MAKE SURE IT IS A FILE PACKAGE ENTITY")
           [/replace TOBEDUMPED of (fetch FILEPROP of NAME)
                                          (FILEPKG.MERGECHANGES (CADR DEFINITION)
                                                 (fetch TOBEDUMPED of (fetch FILEPROP
                                                                                 of NAME]
           (OR (fetch FILEDATES of NAME)
               (/replace FILEDATES of NAME with (CADDR DEFINITION])

(VARS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "29-Jul-85 20:59")
    (/SETTOPVAL NAME DEFINITION T])

(FILES.WHENCHANGED
  [LAMBDA (NAME TYPE REASON)
    (MARKASCHANGED (FILECOMS NAME)
           'VARS REASON])
)

(ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO)

(ADDTOVAR SYSPROPS PROPTYPE)

(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)

(PUTPROPS SUBR PROPTYPE IGNORE)

(PUTPROPS LIST PROPTYPE IGNORE)

(PUTPROPS CODE PROPTYPE IGNORE)

(PUTPROPS FILEDATES PROPTYPE IGNORE)

(PUTPROPS FILE PROPTYPE IGNORE)

(PUTPROPS FILEMAP PROPTYPE IGNORE)

(PUTPROPS EXPR PROPTYPE FNS)

(PUTPROPS VALUE PROPTYPE VARS)

(PUTPROPS COPYRIGHT PROPTYPE FILES)

(PUTPROPS FILETYPE PROPTYPE FILES)

(PUTPROPS BAKTRACELST VARTYPE ALIST)

(PUTPROPS BREAKMACROS VARTYPE ALIST)

(PUTPROPS COMPILETYPELST VARTYPE ALIST)

(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))

(PUTPROPS ERRORTYPELST VARTYPE ALIST)

(PUTPROPS FONTDEFS VARTYPE ALIST)

(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))

(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)

(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)

(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)

(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))



(* ; "Define the commands below AFTER the various properties have been established.")


(ADDTOVAR USERMACROS (M NIL (MAKE FILE FILE))
                         (M (X . Y)
                            (E (MARKASCHANGED (COND ((LISTP 'X)
                                                     (CAR 'X))
                                                    (T 'X))
                                      'USERMACROS)
                               T)
                            (ORIGINAL (M X . Y))))

(ADDTOVAR EDITMACROS (M (X . Y)
                            (E (MARKASCHANGED (COND ((LISTP 'X)
                                                     (CAR 'X))
                                                    (T 'X))
                                      'USERMACROS)
                               T)
                            (ORIGINAL (M X . Y))))

(ADDTOVAR EDITCOMSA M)

(ADDTOVAR EDITCOMSL M)



(* ; "GETDEF methods")

(DEFINEQ

(RENAME
  [LAMBDA (OLD NEW TYPES FILES METHOD)               (* JonL "24-Jul-84 20:01")
    (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD)))

     (* ;; "special kludge: change the callers BEFORE if we are changing a field;  this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message")

          [for TYPE inside TYPES when (NEQ TYPE 'FIELDS)
             do (COPYDEF OLD NEW TYPE NIL (COND
                                                     ((EQ TYPE 'VARS)
                                                      'NOERROR]
          (CHANGECALLERS OLD NEW TYPES FILES METHOD)
          [for TYPE inside TYPES do (COND
                                                   ((AND (EQ TYPE 'FIELDS)
                                                         (HASDEF OLD 'FIELDS))

                                 (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file.  Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.")

                                                    (COPYDEF OLD NEW 'FIELDS))
                                                   (T (DELDEF OLD TYPE]
          (RETURN NEW])

(CHANGECALLERS
  [LAMBDA (OLD NEW AS-TYPES FILES METHOD)            (* ; "Edited  6-Dec-86 01:25 by lmm")
    (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES))
           REL TEM EDITCOMS FNS)
          (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD))
          [SETQ EDITCOMS
           (LIST (COND
                    [(OR (EQMEMB 'CAREFUL METHOD)
                         (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES))
                                (printout T "Warning --" OLD " is also defined as " TEM T)))

                     (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename.  Y means do it, No means skip, anything else goes into TTY.")

                     (SUBPAIR '(OLD NEW)
                            (LIST OLD NEW)
                            '(BIND (LPQ (F OLD N)
                                            (MARK %#1)
                                            (ORR (1 !0 P)
                                                 NIL)
                                            (MARK %#2)
                                            (COMS (SELECTQ (ASKUSER NIL NIL "   Replace ? "
                                                                  '((Y "Yes
")
                                                                    (N "No
")
                                                                    (%
 "")
                                                                    (%  "")
                                                                    (%
 "")
                                                                    (& ""))
                                                                  NIL NIL '(NOECHOFLG T))
                                                      (Y '(R1 OLD NEW))
                                                      (N NIL)
                                                      'TTY%:))
                                            (MARK %#3)
                                            (IF (EQ (%## (\ %#3))
                                                        (%## (\ %#2)))
                                                   ((\ %#1))
                                                   NIL]
                    (T (LIST 'R OLD NEW]
          (SELECTQ (COND
                      ((AND (EQMEMB 'MASTERSCOPE METHOD)
                            MSDATABASELST
                            (for TYPE inside AS-TYPES
                               do [COND
                                         ((SETQ TEM (SELECTQ TYPE
                                                        ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 
                                                             'CALL)
                                                        (MACROS '(CALL DIRECTLY))
                                                        ((VARS VARIABLES) 
                                                             '(USE OR BIND))
                                                        ((RECORDS FIELDS I.S.OPRS) 
                                                             (LIST 'USE 'AS TYPE))
                                                        (RETURN NIL)))
                                          (COND
                                             (REL (SETQ REL (LIST TEM 'OR REL)))
                                             (T (SETQ REL TEM] FINALLY (RETURN REL)))

                       (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known")

                       'MASTERSCOPE)
                      ((EQMEMB 'EDITCALLERS METHOD)
                       'EDITCALLERS)
                      (T 'SEARCH))
              (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND
                                                     ((NULL FILES)
                                                      (UPDATEFILES)
                                                      (FILEPKGCHANGES 'FNS]
                                                  (for FILE inside (OR FILES FILELST)
                                                     join (FILEFNSLST FILE]
                                 (FUNCTION UPDATEFN))
                           (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL))
                                                          T)
                                            FNS)))
              (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST)
                                          when (SETQ TEM (EDITCALLERS OLD X T))
                                          collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM)))
                                                             X))))
              (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST
                                                                                   X))))
              (ERROR "UNRECOGNIZED RENAME METHOD" METHOD))
          (AND (EQMEMB 'FNS AS-TYPES)
               (FMEMB OLD FNS)
               (SETQ FNS (REMOVE OLD FNS)))
          (EDITFROMFILE FNS FILES OLD EDITCOMS)
          [for TYPE inside AS-TYPES
             do (for FILE in (WHEREIS OLD TYPE FILES)
                       do (AND (ADDTOFILE NEW TYPE FILE)
                                   (DELFROMFILES OLD TYPE FILE)
                                   (printout T OLD " changed to " NEW " on " FILE)))
                   (COND
                      ((SETQ TEM (WHEREIS OLD TYPE FILES))
                       (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM]
          (COND
             (REL (UPDATECHANGED)
                  (COND
                     ((AND (SETQ TEM (GETRELATION OLD REL T))
                           (WHEREIS TEM 'FNS FILES))
                      (printout T "Couldn't find where " OLD " is referenced in " TEM T])
)
(DEFINEQ

(SHOWDEF
  [LAMBDA (NAME TYPE FILE)                              (* ; "Edited 16-Apr-2018 21:35 by rmk:")
                                                             (* ; 
                                                 "prettyprint NAME as it would be dumped as a TYPE")
    (RESETLST
        (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
              (DECLARE (SPECVARS . T))
              [AND FILE (NEQ FILE (OUTPUT))
                   (if (SETQ FL (OPENP FILE 'OUTPUT))
                       then (RESETSAVE (OUTPUT FL))
                     else (OUTFILE FILE)
                           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                                (OUTPUT]
              (PRETTYCOM (MAKENEWCOM NAME TYPE))))])

(COPYDEF
  [LAMBDA (OLD NEW TYPE SOURCE OPTIONS)              (* lmm "14-Aug-84 18:38")
                                                             (* ; "like MOVD, but takes a type.")
    (PROG (TEM DEF)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          [SETQ DEF (GETDEF OLD TYPE SOURCE (COND
                                                   ((EQ OPTIONS 'NOCOPY)
                                                    NIL)
                                                   (T (REMOVE 'NOCOPY (MKLIST OPTIONS]
                                                             (* ; 
      "The default is for GETDEF to return a COPY.  Make sure that NOCOPY isn't in options though.")
          (SELECTQ TYPE
              (VARS)
              (FILES [for X in (CAR DEF)
                        do                               (* ; 
                                          "change all the listnames which are of form filenameTYPE")
                              (SELECTQ (CAR X)
                                  ((PROP IFPROP) 
                                       (SETQ X (CDR X)))
                                  NIL)
                              (COND
                                 ((EQ (CADR X)
                                      '*)
                                  (SETQ X (CDDR X))
                                  (COND
                                     ((AND (LITATOM (CAR X))
                                           (SETQ TEM (STRPOS OLD (CAR X)
                                                            1 NIL T T)))
                                      (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X)
                                                                           TEM -1)))
                                             (COPY (GETTOPVAL (CAR X)))
                                             T)
                                      (FRPLACA X TEM])
              ((PROPS ALISTS) 
                   (OR (EQ (CAR NEW)
                           (CAR OLD))
                       (DSUBST (CAR NEW)
                              (CAR OLD)
                              DEF))
                   (OR (EQ (CADR NEW)
                           (CADR OLD))
                       (DSUBST (CADR NEW)
                              (CADR OLD)
                              DEF)))
              (DSUBST NEW OLD DEF))
          (PUTDEF NEW TYPE DEF)
          (RETURN NEW])

(GETDEF
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "13-Jul-85 04:10")

    (* ;; "returns the definition of NAME as a TYPE from SOURCE;  cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found.  The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.")

    (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS)))
          (DECLARE (SPECVARS NOCOPY))
          (SELECTQ OPTIONS
              (0 (SETQQ OPTIONS (NOERROR NODWIM))
                 (SETQ NOCOPY T))
              (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST))
                 (SETQ NOCOPY T))
              (T (SETQQ OPTIONS SPELL))
              NIL)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          (SELECTQ SOURCE
              (0 (SETQQ SOURCE CURRENT))
              (T (SETQQ SOURCE SAVED))
              (NIL (SETQQ SOURCE ?))
              NIL)
          [SELECTQ SOURCE
              (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS)))
              (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS]
                      (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS])
              (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS)))
              (COND
                 ((AND (LISTP SOURCE)
                       (EQ (CAR SOURCE)
                           '=))
                  (SETQ DEF (CDR SOURCE)))
                 (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS))
                    (SETQ NOCOPY T]
          (OR NOCOPY (SETQ DEF (COPY DEF)))
          (COND
             ((AND (EQ TYPE 'FNS)
                   (NOT (EQMEMB 'NODWIM OPTIONS)))
              (DWIMDEF DEF NAME SOURCE)))
          (RETURN DEF])

(GETDEFCOM
  [LAMBDA (X)                                            (* lmm " 4-Jul-85 13:31")

    (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in.  Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed.  --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.  That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.")
                                                             (* ; "a RETFROM point")
    (for Y in X join (GETDEFCOM0 Y])

(GETDEFCOM0
  [LAMBDA (COM)                                          (* wt%: " 7-FEB-79 23:28")
    (PROG (TEM)
          (RETURN (COND
                     ((SETQ TEM (fetch MACRO of (CAR COM)))
                                                             (* COND ((fetch CONTENTS of
                                                           (CAR COM)) (* ; 
                        "if it has a CONTENTS function, generally means it is not safe to evaluate")
                                                           (RETFROM (QUOTE GETDEFCOM))))
                      (for Y in (SUBPAIR (CAR TEM)
                                               (PRETTYCOM1 COM)
                                               (CDR TEM)) join (GETDEFCOM0 Y)))
                     (T (SELECTQ (CAR COM)
                            (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X)))
                            (ADDVARS (for Y in (PRETTYCOM1 COM)
                                        collect (CONS 'ADDTOVAR Y)))
                            (APPENDVARS (for Y in (PRETTYCOM1 COM)
                                           collect (CONS 'APPENDTOVAR Y)))
                            (P (APPEND (PRETTYCOM1 COM)))
                            (RETFROM 'GETDEFCOM])

(GETDEFCURRENT
  [LAMBDA (NAME TYPE OPTIONS)                            (* ; "Edited  2-May-87 19:00 by Pavel")
                                                             (* ; 
                                                           "Gets the current definition--source=0")
    (LET
     (DEF)
     (COND
        ((AND (SETQ DEF (fetch GETDEF of TYPE))
              (NEQ DEF T))

         (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")

         (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS))
                  (fetch NULLDEF of TYPE))
             (GETDEFERR NAME TYPE OPTIONS))
         DEF)
        (T
         (OR
          (NEQ
           [SETQ DEF
            (SELECTQ TYPE
                (FNS (AND (LITATOM NAME)
                          (EXPRP (SETQ DEF (VIRGINFN NAME)))
                          DEF))
                (VARS (if (LITATOM NAME)
                          then (GETTOPVAL NAME)
                        else 'NOBIND))
                ((FIELDS RECORDS) 
                     (if (LITATOM NAME)
                         then [SETQ DEF (SELECTQ TYPE
                                                (RECORDS (RECLOOK NAME))
                                                (MKPROGN (FIELDLOOK NAME]
                               (if (EQMEMB 'EDIT OPTIONS)
                                   then (COPY DEF)
                                 else DEF)))
                (FILES                                       (* ; 
              "what is the `definition' of a file?  -- I guess the COMS which say what it contains")
                       [if (LITATOM NAME)
                           then (if (SETQ DEF (GETFILEDEF NAME))
                                        then (UPDATEFILES)
                                              (LIST (LISTP (GETTOPVAL (FILECOMS DEF)))
                                                    (fetch TOBEDUMPED
                                                       of (fetch FILEPROP of DEF))
                                                    (LISTP (fetch FILEDATES of DEF])
                (TEMPLATES (if (AND (LITATOM NAME)
                                        (SETQ DEF (GETTEMPLATE NAME)))
                               then (LIST 'SETTEMPLATE (KWOTE NAME)
                                              (KWOTE DEF))))
                (MACROS [if [AND (LITATOM NAME)
                                     (SETQ DEF (for X on (GETPROPLIST NAME)
                                                  by (CDDR X) when (FMEMB (CAR X)
                                                                                  MACROPROPS)
                                                  join (LIST (CAR X)
                                                                 (CADR X]
                            then `(PUTPROPS ,NAME ,@DEF])
                (EXPRESSIONS (LISTP NAME))
                (PROPS [AND (LISTP NAME)
                            (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME))
                                                 [FUNCTION (LAMBDA (X)
                                                             (EQ X (CADR NAME]
                                                 (FUNCTION CDDR)))
                                 (LIST 'PUTPROPS (CAR NAME)
                                       (CADR NAME)
                                       (CADR DEF])
                (FILEPKGCOMS [AND (LITATOM NAME)
                                  (PROG ((COM (FILEPKGCOM NAME))
                                         (TYP (FILEPKGTYPE NAME)))
                                        (RETURN (COND
                                                   ((AND COM TYP)
                                                    (LIST (CONS 'COM COM)
                                                          (CONS 'TYPE TYP)))
                                                   (COM (LIST (CONS 'COM COM)))
                                                   (TYP (LIST (CONS 'TYPE TYP])
                (FILEVARS (COND
                             ((AND (LITATOM NAME)
                                   (LISTP (SETQ DEF (GETTOPVAL NAME)))
                                   (WHEREIS NAME 'FILEVARS))
                              DEF)
                             (T 'NOBIND)))
                (LET
                 ((COMS (LIST (MAKENEWCOM NAME TYPE)))
                  FILE)
                 [COND
                    ((NOT (SETQ DEF (GETDEFCOM COMS)))
                     (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
                         (RESETLST
                             (RESETSAVE PRETTYFLG)
                             (RESETSAVE FONTCHANGEFLG)
                             [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
                             (PRETTYDEFCOMS COMS)
                             (SETFILEPTR FILE 0)
                             [SETQ DEF
                              (for X in (READFILE FILE)
                                 join
                                 (SELECTQ (CAR X)
                                     ((*) 
                                          NIL)
                                     (DECLARE%: (for Y on (CDR X)
                                                   unless (SELECTQ (CAR Y)
                                                                  ((COPYWHEN EVAL@LOADWHEN 
                                                                          EVAL@COMPILEWHEN) 
                                                                       (RETURN (LIST Y)))
                                                                  (FMEMB (CAR Y)
                                                                         DECLARETAGSLST))
                                                   collect (CAR Y)))
                                     (CL:EVAL-WHEN (CDDR X))
                                     (PROGN (CDR X))
                                     (LIST X]
                             (SETQ NOCOPY T)))]
                 (MKPROGN DEF]
           (fetch NULLDEF of TYPE))
          (GETDEFERR NAME TYPE OPTIONS))
         DEF])

(GETDEFERR
  [LAMBDA (NAME TYPE OPTIONS MSG)                        (* lmm "13-Jul-85 04:11")
    (DECLARE (USEDFREE NODEF))                           (* ; 
                                       "Message non-null if looking for saved or filed definition.")
    (PROG (TEM)
          (RETURN (COND
                     ((EQMEMB 'NOERROR OPTIONS)              (* ; 
                                               "We want to do the string search in the HASDEF case")
                      (RETURN (fetch NULLDEF of TYPE)))
                     [(AND (NULL MSG)
                           (EQMEMB 'SPELL OPTIONS)
                           (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS)
                                                                          'SPELL)
                                                                   T)))
                           (NEQ TEM NAME))
                      (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS]
                     (T (for O inside OPTIONS when (STRINGP O)
                           do (RETFROM 'GETDEF O)
                           finally (ERROR NAME (CONS TYPE '(definition not found))
                                              T])

(GETDEFFROMFILE
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: " 1-Oct-86 22:10")

    (* ;; "Tries to get definition from source file.  If successful, returns the definition.  Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.")

    (DECLARE (SPECVARS NAME))
    (bind (NOTFOUND _ "not found")
           DEF SOURCE TEM2 for FILE inside (COND
                                                      ((EQ SOURCE 'FILE)
                                                       (WHEREIS NAME TYPE T))
                                                      (T SOURCE))
       when
       (AND
        (SETQ SOURCE (FINDFILE FILE T))
        (NEQ
         [SETQ DEF
          (COND
             ((SETQ TEM2 (fetch FILEGETDEF of TYPE))
              (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND))
             (T
              (SELECTQ TYPE
                  (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  ((VARS FILEVARS) 
                       (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (COND
                     [(SETQ DEF (GET TYPE 'DEFINERS))
                      (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF
                                        `(LAMBDA (FIRST SECOND)
                                           (AND (MEMB FIRST ',DEF)
                                                (OR (EQ SECOND NAME)
                                                    (AND (MEMB SECOND '(%( %[))
                                                         (PROGN (RATOM)
                                                                (RATOM)
                                                                (RATOM)
                                                                (EQ NAME (RATOM]
                                                             (* ; "ick!  Should use real closure")
                           (if (EQ (CAAR VAL)
                                       'NOT-FOUND)
                               then NOTFOUND
                             elseif (CDR VAL)
                               then (CONS 'PROGN VAL)
                             else (CAR VAL]
                     (T (RESETLST
                            (RESETSAVE (RESETUNDO))
                            [LET (LOAD-VERBOSE-STREAM)
                                 (DECLARE (SPECVARS LOAD-VERBOSE-STREAM))
                                                             (* ; 
                                                     "just in case we get a PRETTYCOMPRINT in here")
                                 (LOADFNS NIL SOURCE 'PROP (COND
                                                              ((LITATOM NAME)
                                                             (* ; 
                                         "If an atom, only bother with expressions that contain it")
                                                               (CONS (LIST '& '|..| NAME)))
                                                              (T T]
                            (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))]
         NOTFOUND)) do (AND (EQ SOURCE 'FILE)
                                (OR (FMEMB FILE FILELST)
                                    (CL:FORMAT T "(from ~A)~%%" SOURCE))) 
                                                             (* ; 
                                                        "Copying and dwimifying are done in GETDEF")
                          (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
                                                                  (APPEND '(no definition on)
                                                                         (MKLIST SOURCE])

(GETDEFSAVED
  [LAMBDA (NAME TYPE OPTIONS)                          (* ; "Edited 11-Aug-87 18:14 by cutting")
                                                             (* ; 
                                                           "Gets the `saved' definition--source=T")
    (SELECTQ TYPE
        (FNS (OR (GETPROP NAME 'EXPR)
                 (GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
        (VARS                                                (* ; 
                               "The value of a variable is never substituted into and never COPIED")
              (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
                                                                                'VALUE)
                 do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS 
                                                                     "no saved value for "))))
        (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS)))
            (GETDEFERR NAME TYPE OPTIONS "no saved definition for "])

(PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* ; "Edited  8-Apr-87 12:52 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE)))
         (COND
            (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON))
            (T (SELECTQ TYPE
                   (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON))
                   (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON))
                   (EVAL DEFINITION))
               NAME])

(EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)
    (DECLARE (LOCALVARS . T)
           (SPECVARS SOURCE))                          (* ; "Edited 27-Jul-87 11:04 by cutting")

    (* ;; "lets you edit anything.  Given name and type, call editor on the definition (loading it in from SOURCE if necessary).  If you change it, then the definition gets unsaved.  OPTIONS is passed through from ED to the editor.")

    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (COND
       ((AND (fetch EDITDEF of TYPE)
             (APPLY* (fetch EDITDEF of TYPE)
                    NAME TYPE SOURCE EDITCOMS OPTIONS)))
       ((AND (EQ TYPE 'FNS)
             (NULL SOURCE))                                  (* ; 
                                "special hack for EDITDEF of FNS because of ability to EDITLOADFNS")
        (EDITDEF.FNS NAME EDITCOMS OPTIONS))
       (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))
    NAME])

(DEFAULT.EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 11-Jun-92 16:26 by cat")
    (PROG [(DEF (COND
                   [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
                   [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
                   [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
                   (T (LET ((FILES (WHEREIS NAME TYPE T)))
                           (CL:IF (NULL FILES)
                               (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE)
                               [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME 
                                                         FILES)
                                                  (CL:IF (CL:ENDP (CDR FILES))
                                                      (CL:IF (CL:Y-OR-N-P 
                                                                    "Shall I load this file PROP? ")
                                                             (CAR FILES))
                                                      (ASKUSER NIL NIL 
                                                             "indicate which file to load PROP: "
                                                             (MAKEKEYLST FILES)
                                                             T))]
                                    (CL:WHEN FILE
                                        (LOAD FILE 'PROP)
                                        (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])]

     (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")

          (DECLARE (SPECVARS RETRY))

     (* ;; "what is RETRY ???")

          (SETQ RETRY)
          (CL:WHEN DEF
              (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
                                                             (* ; 
                                             "this function is called when there were changes made")
                                                        (FIXEDITDATE DEF)
                                                             (* ; "fix the edit date first - jtm")
                                                        (PUTDEF NAME TYPE DEF)
                                                        (MARKASCHANGED NAME TYPE 'CHANGED)

                                 (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition.  doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here.  this sometimes results in MARKASCHANGED getting called twice.")

                                                        ]
                     OPTIONS))])

(EDITDEF.FILES
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 18-Mar-87 16:07 by woz")
    (EDITDEF (FILECOMS NAME)
           'VARS SOURCE EDITCOMS OPTIONS])

(LOADDEF
  [LAMBDA (NAME TYPE SOURCE)                             (* lmm "13-SEP-78 01:34")
    (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY])

(DWIMDEF
  [LAMBDA (DEF FN SOURCE)                                (* lmm " 6-Jun-86 17:23")
    (AND [OR (EQ DWIMIFYCOMPFLG T)
             (EQ CLISPIFYPRETTYFLG T)
             (EQ (CAR (CADDR DEF))
                 'CLISP%:)
             (SELECTQ SOURCE
                 ((CURRENT SAVED FILE ?) 
                      NIL)
                 (AND (LITATOM SOURCE)
                      (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE]
         (LET ((NOSPELLFLG T)
               (DWIMESSGAG T)
               FILEPKGFLG LISPXHIST)
              (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST))
              (DWIMIFY0 DEF (COND
                               ((OR (LISTP FN)
                                    (NULL FN))
                                '?)
                               (T FN))
                     NIL DEF])

(DELDEF
  [LAMBDA (NAME TYPE)                                    (* ; "Edited  5-Dec-86 06:20 by lmm")
    (PROG (TEM)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
      LP  [COND
             ((SETQ TEM (fetch DELDEF of TYPE))
              (APPLY* TEM NAME TYPE))
             (T (SELECTQ TYPE
                    (FNS                                     (* ; 
  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such")
                         (AND (EXPRP NAME)
                              (/PUTD NAME))
                         (REMPROP NAME 'EXPR)
                         [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME])
                    (VARS (/SETTOPVAL NAME 'NOBIND))
                    (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES)
                              do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST]
                           (/replace FILEPROP of NAME with NIL)
                           (/replace FILECHANGES of NAME with NIL)
                           (/replace FILEDATES of NAME with NIL)
                           (FLUSHFILEMAPS NAME))
                    (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME)
                                 (DELFROMLIST 'FILEPKGTYPES NAME)
                                 (for FIELD on (FILEPKGCOM NAME)
                                    by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD)
                                                                      NIL))
                                 (for FIELD on (FILEPKGTYPE NAME)
                                    by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD)
                                                                      NIL))
                                 (/replace ALLFIELDS of NAME with NIL))
                    (ALISTS [AND (LISTP NAME)
                                 (DELFROMLIST (CAR NAME)
                                        (FASSOC (CADR NAME)
                                               (GETTOPVAL (CAR NAME])
                    (MACROS (for P in MACROPROPS do (/REMPROP NAME P)))
                    (PROPS (AND (LISTP NAME)
                                (/REMPROP (CAR NAME)
                                       (CADR NAME))))
                    (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS))
                                 (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS
                                                                             ))
                                 (DELFROMLIST 'LISPXCOMS NAME)
                                 (DELFROMLIST 'HISTORYCOMS NAME))
                    (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet")
                           T]
          (MARKASCHANGED NAME TYPE 'DELETED)
          (RETURN NAME])

(DELFROMLIST
  [LAMBDA (VAR VAL)                                      (* rmk%: " 3-JAN-82 23:22")
    (AND (FMEMB VAL (GETTOPVAL VAR))
         (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR)
                                (FUNCTION (LAMBDA (X)
                                            (AND (NEQ X VAL)
                                                 (OR (NLISTP X)
                                                     (NEQ (CDR X)
                                                          VAL])

(HASDEF
  [LAMBDA (NAME TYPE SOURCE SPELLFLG)                    (* ; "Edited 31-Aug-87 18:02 by drc:")

    (* ;; "is NAME the name of something of type TYPE?  NIL SOURCE means 0, not ?")

    (DECLARE (SPECVARS TYPE))
    (COND
       [[OR (LISTP TYPE)
            (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG")
        (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
                                            (RETURN $$VAL]
       (T
        (PROG [(NODEF (fetch NULLDEF of TYPE))
               (OPTS '(NODWIM NOCOPY NOERROR HASDEF]
              (COND
                 ((NULL SOURCE)
                  (SETQQ SOURCE CURRENT)))
              (RETURN
               (SELECTQ SOURCE
                   ((CURRENT 0) 
                        [COND
                           ([OR
                             (MEMBER NAME (fetch CHANGED of TYPE))
                             (LET ((TM (fetch HASDEF of TYPE)))
                                  (COND
                                     (TM (APPLY* TM NAME TYPE SOURCE))
                                     [(NOT (LITATOM NAME))
                                      (SELECTQ TYPE
                                          (PROPS (AND (LISTP NAME)
                                                      (GETPROP (CAR NAME)
                                                             (CADR NAME))))
                                          ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS 
                                                  FIELDS USERMACROS FILEVARS FILEPKGCOMS) 
                                               NIL)
                                          (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                                     (T 
                                        (* ;; "symbol definitions")

                                        (SELECTQ TYPE
                                            (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS")
                                                                        "INTERLISP")))
                                                        (AND SYMBOL (BOUNDP SYMBOL))))
                                            (TEMPLATES (GETTEMPLATE NAME))
                                            (MACROS (GETLIS NAME MACROPROPS))
                                            (LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
                                                             (FASSOC NAME LISPXHISTORYMACROS)))
                                            (VARS (AND (NOT (CL:KEYWORDP NAME))
                                                       (NEQ (GETTOPVAL NAME)
                                                            'NOBIND)))
                                            (RECORDS (RECLOOK NAME))
                                            (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD]
                                                            (RETURN (AND TEM (EQ (CAR TEM)
                                                                                 'FORWORD)
                                                                         (GETPROP (CDR TEM)
                                                                                'I.S.OPR])
                                            (FNS (AND (OR (AND (GETD NAME)
                                                               (EXPRP (GETD NAME)))
                                                          (GET NAME 'EXPR))
                                                      (NOT (HASDEF NAME 'FUNCTIONS SOURCE))))
                                            (FIELDS (RECORDFIELD? NAME))
                                            (USERMACROS (FASSOC NAME USERMACROS))
                                            (FILEVARS)
                                            ((PROPS ALISTS DEFS EXPRESSIONS) 
                                                 NIL)
                                            (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
                                                             (FMEMB NAME FILEPKGTYPES)))
                                            (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                            (OR NAME T))
                           (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME)
                                         (FIXSPELL NAME NIL
                                                (SELECTQ TYPE
                                                    (FILES FILELST)
                                                    (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES))
                                                    (FIELDS (for X in USERRECLST
                                                               join (APPEND (RECORDFIELDNAMES
                                                                                 X))))
                                                    (RECORDS (for X in USERRECLST
                                                                when (LITATOM (CADR X))
                                                                collect (CADR X)))
                                                    (LISPXMACROS LISPXCOMS)
                                                    (I.S.OPRS I.S.OPRLST)
                                                    (USERMACROS (MAPCAR USERMACROS
                                                                       (FUNCTION CAR)))
                                                    USERWORDS)
                                                NIL
                                                (LISTP SPELLFLG)
                                                [FUNCTION (LAMBDA (X)
                                                            (HASDEF X TYPE 'CURRENT]
                                                NIL T))])
                   (? (OR (HASDEF NAME TYPE 'CURRENT)
                          (AND (LITATOM NAME)
                               (HASDEF NAME TYPE 'SAVED SPELLFLG))
                          (WHEREIS NAME TYPE T)))
                   ((SAVED T) 
                        (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS)))
                   (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])

(GETFILEDEF
  [LAMBDA (FILENAME)                                     (* lmm " 4-Jul-85 13:25")

    (* ;; 
  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST")

    (COND
       ((FMEMB FILENAME FILELST)
        FILENAME)
       (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T)
             do (COND
                       ((EQ (FILENAMEFIELD FILE 'NAME)
                            FILENAME)
                        (RETURN FILE])

(SAVEDEF
  [LAMBDA (NAME TYPE DEFINITION)                         (* JonL "24-Jul-84 20:11")
    (COND
       [(AND (LISTP NAME)
             (NULL TYPE))
        (MAPCAR NAME (FUNCTION (LAMBDA (I)
                                 (SAVEDEF I 'FNS]
       (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME)))
                        (/PUT NAME [SETQ TYPE (COND
                                                 ((SUBRP DEFINITION)
                                                  'SUBR)
                                                 ((EXPRP DEFINITION)
                                                  'EXPR)
                                                 ((CCODEP DEFINITION)
                                                  'CODE)
                                                 (T 'LIST]
                              DEFINITION)))
              (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME)))
                              'NOBIND)
                         (EQ DEFINITION (GETTOPVAL NAME))
                         (/PUT NAME (SETQ TYPE 'VALUE)
                               DEFINITION)))
              (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT
                                                          '(NOCOPY NOERROR NODWIM]
                   (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS))
                                                  (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME))
                                                                             SAVEDDEFS]
          TYPE])

(UNSAVEDEF
  [LAMBDA (NAME TYPE DEF)                                (* lmm " 6-Jun-86 17:24")
    (SELECTQ TYPE
        ((NIL EXPR CODE SUBR LIST) 
             (COND
                [(LISTP NAME)                                (* ; "for compatibility")
                 (MAPCAR NAME (FUNCTION (LAMBDA (X)
                                          (UNSAVED1 X TYPE]
                (T (UNSAVED1 NAME TYPE))))
        (PROG NIL
              [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
                                       'SAVED 0))
                  (RETURN (CONS TYPE '(not found]
              (COND
                 ((NEQ DFNFLG T)
                  (SAVEDEF NAME TYPE)
                  (LET ((DFNFLG T))
                       (PUTDEF NAME TYPE DEF)))
                 (T (PUTDEF NAME TYPE DEF)))
              (RETURN TYPE])

(COMPAREDEFS
  [LAMBDA (NAME TYPE SOURCES)                            (* lmm " 4-Jul-85 14:37")
    (COND
       ((AND (LISTP TYPE)
             (GETFILEPKGTYPE SOURCES NIL T))
        (swap TYPE SOURCES)))
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T]
          [COND
             ((NULL SOURCES)
              (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE))
                       (SOME SRCS (FUNCTION (LAMBDA (FILE)
                                              (MEMBER NAME (CDR (ASSOC TYPE
                                                                       (fetch TOBEDUMPED
                                                                          of (fetch FILEPROP
                                                                                    of FILE]
                   (push SRCS 'CURRENT]
          (SETQ SRCS (for SRC in SRCS
                        when (COND
                                    ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
                                          (fetch NULLDEF of TYPE))
                                     (OR [SOME DEFS (FUNCTION (LAMBDA (DP)
                                                                (COMPARELST DEF (CDR DP]
                                         (push DEFS (CONS SRC DEF)))
                                     T)
                                    (T (PRINTOUT T "No " SRC " definition found for " NAME T)
                                       NIL)) collect SRC))
          (RETURN (COND
                     ((NULL SRCS)
                      '(no definitions found))
                     ((NULL (CDR SRCS))
                      '(only one definition found))
                     ((CDR DEFS)
                      [for S1 on (DREVERSE DEFS)
                         do (for S2 on (CDR S1) do (PRIN2 NAME T T)
                                                                  (AND (CAAR S1)
                                                                       (PRIN1 " from " T)
                                                                       (PRIN2 (CAAR S1)
                                                                              T T))
                                                                  (PRIN1 " and " T)
                                                                  (PRIN2 NAME T T)
                                                                  (COND
                                                                     ((CAAR S2)
                                                                      (PRIN1 " from " T)
                                                                      (PRIN2 (CAAR S2)
                                                                             T T)))
                                                                  (PRIN1 " differ:" T)
                                                                  (TERPRI T)
                                                                  (COMPARELISTS (CDAR S1)
                                                                         (CDAR S2]
                      'DIFFERENT)
                     (T 'SAME])

(COMPARE
  [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2)             (* lmm " 5-SEP-78 13:37")
    (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY]
           (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY]
          (COND
             ((COMPARELST DEF1 DEF2)
              (RETURN)))
          (PRIN2 NAME1 T T)
          (COND
             (SOURCE1 (PRIN1 " from " T)
                    (PRIN2 SOURCE1 T T)))
          (PRIN1 " and " T)
          (PRIN2 NAME2 T T)
          (COND
             (SOURCE2 (PRIN1 " from " T)
                    (PRIN2 SOURCE2 T T)))
          (PRIN1 " differ:" T)
          (TERPRI T)
          (COMPARELISTS DEF1 DEF2)
          (RETURN T])

(TYPESOF
  [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER)
                                                          (* ; "Edited  2-Aug-88 02:08 by masinter")

    (* ;; "return list of all known types which NAME names")

    (LET
     (FOUND SHADOWED)
     (if (FMEMB SOURCE '(? NIL))
         then (CL:FLET [(RSHADOW NIL (for X in FOUND
                                            do (for Y in (CDR (FASSOC X SHADOW-TYPES))
                                                      do (if (FMEMB Y FOUND)
                                                                 then 
                                                             (* ; "shadower found before shadowed")
                                                                       (SETQ FOUND (REMOVE Y FOUND]
                         (LET (NOTFOUND NEWTYPES)
                              (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                                 when [AND (LITATOM TYPE)
                                               (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                               (OR (NULL FILTER)
                                                   (CL:FUNCALL FILTER TYPE))
                                               (NOT (find X in FOUND
                                                       suchthat (FMEMB TYPE
                                                                           (CDR (FASSOC X 
                                                                                       SHADOW-TYPES]
                                 do (if [OR (HASDEF NAME TYPE 'CURRENT)
                                                    (AND (LITATOM NAME)
                                                         (HASDEF NAME TYPE 'SAVED]
                                            then (push FOUND TYPE)
                                          else (push NOTFOUND TYPE)))
                              (RSHADOW)
                              [for FILE in FILELST while NOTFOUND
                                 when [NEQ T (fetch LOADTYPE of (GETPROP FILE
                                                                                   'FILE]
                                 do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND
                                                                      (FILECOMS FILE)
                                                                      'TYPESOF))
                                            then [bind X for TYPE in NEWTYPES
                                                        when (FMEMB TYPE NOTFOUND)
                                                        do (push FOUND TYPE)
                                                              (if (SETQ X (FASSOC TYPE 
                                                                                     SHADOW-TYPES))
                                                                  then (SETQ NOTFOUND
                                                                            (LDIFFERENCE NOTFOUND X))
                                                                else (SETQ NOTFOUND
                                                                          (REMOVE TYPE NOTFOUND]
                                                  (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES]
                              (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF))
                                  then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND))
                                        (SETQ FOUND (UNION NEWTYPES FOUND)))
                              (RSHADOW)
                              FOUND))
       else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                   when (AND (LITATOM TYPE)
                                 (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                 (OR (NULL FILTER)
                                     (CL:FUNCALL FILTER TYPE))
                                 (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE)))
     FOUND])
)

(RPAQ? WHEREIS.HASH )



(* ; "Must come after PUTDEF")

(DEFINEQ

(FIXEDITDATE
  [LAMBDA (EXPR)                                         (* ; "Edited 17-Jul-89 11:13 by jtm:")
                                                             (* NOBIND "18-JUL-78 21:11")
                                                             (* Inserts or replaces previous edit 
                                                           date)
    (AND INITIALS (LISTP EXPR)
         (LISTP (CDR EXPR))
         (PROG (E)
               (COND
                  ((FMEMB (CAR EXPR)
                          LAMBDASPLST)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR)))
                  [(FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-ARGLIST-DEFINERS)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR))
                   (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
                      finally (SETQ E (CDR E]
                  ((FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-NAME-DEFINERS)

                   (* ;; "insert the edit date after the name")

                   (SETQ E (CDDR EXPR)))
                  (T (RETURN)))
           RETRY
               [COND
                  ((NLISTP E)
                   (RETURN))
                  ((LISTP (CAR E))
                   (SELECTQ (CAAR E)
                       ((CLISP%: DECLARE) 
                            (SETQ E (CDR E))
                            (GO RETRY))
                       (BREAK1 (COND
                                  ((EQ (CAR (CADAR E))
                                       'PROGN)
                                   (SETQ E (CDR (CADAR E)))
                                   (GO RETRY))))
                       (ADV-PROG                             (* No easy way to mark cleanly the 
                                                           date of an advised function)
                                 (RETURN))
                       (COND
                          ((AND (EQ (CAAR E)
                                    COMMENTFLG)
                                (EQ (CADAR E)
                                    'DECLARATIONS%:))
                           (SETQ E (CDR E))
                           (GO RETRY]
               (COND
                  ([for TAIL on E while (AND (LISTP (CAR TAIL))
                                                         (EQ (CAAR TAIL)
                                                             COMMENTFLG))
                      do (COND
                                ((AND (LISTP (CDR TAIL))
                                      (EDITDATE? (CAR TAIL)))
                                 (/RPLACA TAIL (EDITDATE (CAR TAIL)
                                                      INITIALS))
                                 (RETURN T]                  (* scans the comments for a 
                                                           timestamp for this user.)
                   NIL)
                  (T                                         (* attach the new timestamp at the 
                                                           beginning of the comments.)
                     (/ATTACH (EDITDATE NIL INITIALS)
                            E)))
               (RETURN EXPR])

(EDITDATE?
  [LAMBDA (COMMENT)                                      (* ; "Edited 11-Jun-92 16:44 by cat")
                                                             (* ; "Edited 13-Jul-89 09:30 by jtm:")
                                                             (* lmm "21-Mar-85 08:45")

         (* Tests to see if a given common is in fact an edit date --
       this has to be general enough to recognize the most comment comment forms while 
       specific enough to not recognize things that are not edit dates)

    (DECLARE (LOCALVARS . T))                            (* jtm%: changed test so that it 
                                                           creates one timestamp per user.)
    (COND
       [(LISTP COMMENT)
        (COND
           ((EQ (CAR COMMENT)
                COMMENTFLG)
            [COND
               (NIL (NULL NORMALCOMMENTSFLG)
                    (SETQ COMMENT (GETCOMMENT COMMENT]
            (COND
               ([OR (NOT (LISTP (CDR COMMENT)))
                    (NOT (LISTP (CDDR COMMENT]
                NIL)
               [(EQ (CADR COMMENT)
                    ';)                                      (* ; "CL style comment")
                (STRPOS INITIALS (CADDR COMMENT)
                       (IMINUS (NCHARS INITIALS]
               (T                                            (* ; "IL style comment")
                  (EQ (CADR COMMENT)
                      INITIALS]
       ((STRINGP COMMENT])
)



(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")


(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))

(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
)



(* ;; 
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
)

(DEFINEQ

(FILEPKGCOM
  [LAMBDA N                                              (* JonL "10-Jul-84 19:38")
    (PROG (TEM (COM (ARG N 1)))
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in '(MACRO CONTENTS DELETE ADD)
                             when (SETQ TEM (FILEPKGCOM COM FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                               (LIST 'COM T))
                          (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                               (LIST 'COM TEM]
                     ((EQ N 2)
                      (SELECTQ (ARG N 2)
                          (ADD (fetch ADD of COM))
                          (DELETE (fetch DELETE of COM))
                          (MACRO (fetch MACRO of COM))
                          ((CONTENTS CONTAIN) 
                               [OR (fetch (FILEPKGCOM CONTENTS) of COM)
                                   (COND
                                      ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM))
                                       (COND
                                          ((EQ COM 'NILL)
                                           COM)
                                          [(EQ (CAR COM)
                                               'LAMBDA)
                                           (CONS (CAR COM)
                                                 (CONS [CONS (CAADR COM)
                                                             (CONS (OR (CADDR (CADR COM))
                                                                       'NAME)
                                                                   (CONS (CADR (CADR COM))
                                                                         (CDDDR (CADR COM]
                                                       (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM]
                                          (T (LIST 'LAMBDA '(COM TYPE NAME)
                                                   (CONS COM '(COM TYPE NAME])
                          (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                        T)
                                   (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST])
                          (ERROR (ARG N 2)
                                 "not file package command property")))
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'COM)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                (/SETTOPVAL 'FILEPKGCOMSPLST
                                                       (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST])
                                         (COND
                                            ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGCOMSPLST
                                                      (CONS (CONS COM TEM)
                                                            (GETTOPVAL 'FILEPKGCOMSPLST]
                                    (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                    (/SETTOPVAL 'FILEPKGCOMSPLST
                                                           (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                       (SELECTQ (ARG N I)
                                           (ADD (/replace (FILEPKGCOM ADD) of COM
                                                   with TEM))
                                           (DELETE (/replace (FILEPKGCOM DELETE) of
                                                                                         COM
                                                      with TEM))
                                           (MACRO (/replace (FILEPKGCOM MACRO) of COM
                                                     with TEM))
                                           ((CONTENTS CONTAIN) 
                                                (/replace (FILEPKGCOM CONTENTS) of COM
                                                   with TEM))
                                           (ERROR (ARG N I)
                                                  "not file package command property"]
                        (MARKASCHANGED COM 'FILEPKGCOMS])

(FILEPKGTYPE
  [LAMBDA N                                              (* lmm " 5-Jul-85 09:07")
    (PROG ((TYPE (ARG N 1))
           TEM)
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in (UNION '(DESCRIPTION)
                                                       FILEPKGTYPEPROPS)
                             when (SETQ TEM (FILEPKGTYPE TYPE FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                               (LIST 'TYPE T))
                          (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]
                               (LIST 'TYPE TEM]
                     [(EQ N 2)
                      (if (FMEMB (ARG N 2)
                                     FILEPKGTYPEPROPS)
                          then (GETPROP TYPE (ARG N 2))
                        else (SELECTQ (ARG N 2)
                                     (DESCRIPTION (fetch DESCRIPTION of TYPE))
                                     (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                                                    T)
                                               (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES])
                                     (ERROR (ARG N 2)
                                            "not file package type property"]
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'TYPE)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T (OR (FMEMB TYPE FILEPKGTYPES)
                                                (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES))))
                                         (COND
                                            ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES))
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM)
                                                                               FILEPKGTYPES]
                                    (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES)
                                                    (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES
                                                                                    ]
                                       (if (FMEMB (ARG N I)
                                                      FILEPKGTYPEPROPS)
                                           then (if TEM
                                                        then (/PUTPROP TYPE (ARG N I)
                                                                        TEM)
                                                      else (/REMPROP TYPE (ARG N I)))
                                         else (SELECTQ (ARG N I)
                                                      (DESCRIPTION (/replace DESCRIPTION
                                                                      of TYPE with TEM))
                                                      (ERROR (ARG N I)
                                                             "not file package command/type property"
                                                             ]
                        (MARKASCHANGED TYPE 'FILEPKGCOMS])
)

(PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS)))

(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)

(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE)
                                                                       (* Revert to NILL when no 
                                                                          longer coercing 
                                                                          PRETTYDEFMACROS to 
                                                                          FILEPKGCOMS)
                                                                       (AND (EQ TYPE 'FILEPKGCOMS)
                                                                            (INFILECOMTAIL COM]
                                                  (TYPE DESCRIPTION "file package commands/types" 
                                                        GETDEF T PUTDEF FILEPKGCOMS.PUTDEF)))
(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X]
                                             (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF 
                                                   WHENCHANGED (ALISTS.WHENCHANGED))))
(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X])
(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS)))
(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED (
                                                                              EXPRESSIONS.WHENCHANGED
                                                                                               )
                                                        EDITDEF NILL)))
(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL)))
(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)
                                                   (TYPE TYPE FILEPKGCOMS)))
(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X]
                                                 CONTENTS
                                                 (LAMBDA (COM NAME TYPE)
                                                        (AND (EQ TYPE 'FILES)
                                                             (SUBSET (INFILECOMTAIL COM)
                                                                    (FUNCTION LITATOM]
                                            (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED)
                                                  EDITDEF EDITDEF.FILES)))
(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X)))
                                               (TYPE NULLDEF NOBIND EDITDEF NILL)))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (FN)
                                                                         (AND (GETPROP FN
                                                                                     'FUNCTIONS)
                                                                              (CL:WARN 
                                                                      "~A has a FUNCTIONS definition"
                                                                                     FN]
                                                  (ORIGINAL (FNS . X)))
                                               CONTENTS NILL)
                                          (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF
                                                T)))
(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X)))
                                                       CONTENTS
                                                       (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                              (AND (NULL ONFILETYPE)
                                                                   (EQ TYPE 'RECORDS)
                                                                   (INFILECOMTAIL COM])
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS)))
(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X)))
                                                       CONTENTS NILL)
                                                  (TYPE DESCRIPTION "LISPX commands")))
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM
                                              MACRO
                                              [X
                                               (DECLARE%:
                                                EVAL@COMPILE
                                                (P
                                                 *
                                                 (MAPCAR
                                                  'X
                                                  (FUNCTION
                                                   (LAMBDA (Y)
                                                          (LET [[FNDEF (GETDEF Y 'FUNCTIONS
                                                                              'CURRENT
                                                                              '(NOCOPY NOERROR]
                                                                (MACDEF (GETDEF Y 'MACROS
                                                                               'CURRENT
                                                                               '(NOCOPY NOERROR]
                                                               (COND
                                                                ((AND FNDEF (EQ (CAR FNDEF)
                                                                                'DEFMACRO))
                                                                 (CL:WARN 
                           "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S."
                                                                        FNDEF)
                                                                 (LIST 'PROGN FNDEF MACDEF))
                                                                (T (OR MACDEF (CL:CERROR 
                                                          "Go ahead and finish writing out the file."
                                                                                     
                                                                       "No MACROS definition for ~A."
                                                                                     Y)
                                                                       (GETDEF Y 'MACROS 'CURRENT]
                                              CONTENTS NILL)
                                             (TYPE DESCRIPTION "Interlisp macros" GETDEF 
                                                   MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY))))
(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)))
(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X]
                                            (TYPE DESCRIPTION "property lists" WHENCHANGED (
                                                                                    PROPS.WHENCHANGED
                                                                                            ))))
(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM
                                               MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (RECORD)
                                                                         (AND (GETPROP RECORD
                                                                                     'STRUCTURES)
                                                                              (CL:WARN 
                                                                     "~A has a STRUCTURES definition"
                                                                                     RECORD]
                                                  (E (RECORDECLARATIONS . X))
                                                  (INITRECORDS . X))
                                               CONTENTS
                                               (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                      (AND (EQ TYPE 'FIELDS)
                                                           (NULL ONFILETYPE)
                                                           (MAPCONC (INFILECOMTAIL COM)
                                                                  (FUNCTION (LAMBDA
                                                                             (X)
                                                                             (APPEND (
                                                                                     RECORDFIELDNAMES
                                                                                      X]
                                              (TYPE DESCRIPTION "records" DELDEF
                                                    (LAMBDA (X)
                                                           (/SETTOPVAL 'USERRECLST
                                                                  (REMOVE (RECLOOK X)
                                                                         USERRECLST])
(PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X)))
                                                      CONTENTS
                                                      (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                             (AND (NULL ONFILETYPE)
                                                                  (EQ TYPE 'RECORDS)
                                                                  (INFILECOMTAIL COM])
(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X)))
                                                      CONTENTS NILL)
                                                 (TYPE DESCRIPTION "edit macros")))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                                (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                          (VAR)
                                                                          (AND (GETPROP VAR
                                                                                      'VARIABLES)
                                                                               (CL:WARN 
                                                                 "~A also has a VARIABLES definition"
                                                                                      VAR]
                                                   (ORIGINAL (VARS . X)))
                                                CONTENTS NILL)
                                           (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF 
                                                 VARS.PUTDEF)))
(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL)))
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X)
                                                                     (P (CONSTANTS . X])

(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
                           (VARIABLES VARS CONSTANTS))

(RPAQ? SAVEDDEFS )



(* ; "EDITCALLERS")

(DEFINEQ

(FINDCALLERS
  [LAMBDA (ATOMS FILES)                                  (* lmm "30-SEP-78 01:36")
    (PROG ((X (EDITCALLERS ATOMS FILES T)))
          (RETURN (NCONC (DREVERSE (CDR X))
                         (AND (CAR X)
                              (LIST (CONS (COND
                                             ((CDR X)
                                              '"plus other places on")
                                             (T 'on))
                                          (CAR X])

(EDITCALLERS
  [LAMBDA (ATOMS FILES COMS)                            (* ; "Edited 18-Apr-2018 10:41 by rmk:")
                                                             (* bvm%: " 3-Nov-86 17:30")
    (LET
     (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN)
     [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS]
     [for FILE in (COND
                             ((NULL FILES)
                              FILELST)
                             ((EQ FILES T)
                              (UNION SYSFILES FILELST))
                             ((LISTP FILES)
                              FILES)
                             (T (LIST FILES)))
        do
        (RESETLST
            [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I)
                  (OR (SETQ FULL (FINDFILE FILE))
                      (RETURN (LISPXPRINT (CONS FILE '(not found))
                                     T T)))
                  [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT]
                  (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM)))
                  (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP)
                         (OR (GET-ENVIRONMENT-AND-FILEMAP FULL)
                             (\PARSE-FILE-HEADER FILESTREAM)))

             (* ;; "Get reader environment of file.  The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists.  Otherwise, read the top of the file")

                  (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV)))
                  (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL))
                  [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS)))
                      (push FFILEPOSPATTERNS
                             (CONS RDTBL (SETQ PATTERNS
                                          (for ATOM in ATOMS
                                             collect (CONCAT
                                                          (COND
                                                             ((EQ (CHCON1 ATOM)
                                                                  (CHARCODE ESCAPE))
                                                              (SETQ ATOM (SUBSTRING ATOM 2 -1))
                                                              "")
                                                             (T " "))
                                                          [COND
                                                             ((SETQ I (STRPOS ' ATOM))
                                                              (SUBSTRING ATOM 1 (SUB1 I)))
                                                             ((STRINGP ATOM))
                                                             (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE
                                                                                  ATOM)))
                                                             (* ; 
                                                           "Keep MKSTRING from putting a prefix on")
                                                                     (MKSTRING ATOM T RDTBL]
                                                          (COND
                                                             (I "")
                                                             (T " "]
                  (for PATTERN in PATTERNS
                     do
                     (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0)))
                     (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA))
                        do
                        (COND
                           ((NULL PRINTFLG)                  (* ; 
                                   "cause the printing of the filename to be saved on history list")
                            (SETQ PRINTFLG T)
                            (LISPXPRIN2 FULL T T T)

                            (* ;; "print with NODOFLG=T means just to record the printing;  the idea is that only those files in which something is found will be remembered on the history list")

                            (LISPXPRIN1 ": " T NIL T)))
                        [OR
                         [AND (NEQ MAP T)
                              (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0)
                                                                    (SETQ MAP (OR (GETFILEMAP 
                                                                                         FILESTREAM)
                                                                                  (LOADFILEMAP 
                                                                                         FILESTREAM]
                                                         (PROGN 
                                                             (* ; "file has no filemap")
                                                                (SETQ MAP (SETQ NOMAPFLG T))
                                                                (LISPXPRIN1 " no filemap!" T)
                                                                NIL)))
                                 thereis (AND (ILESSP (CAR X)
                                                         I)
                                                  (IGREATERP (CADR X)
                                                         I)
                                                  (for Z in (CDDR X)
                                                     thereis (COND
                                                                    ((AND (ILESSP (CADR Z)
                                                                                 I)
                                                                          (IGREATERP (CDDR Z)
                                                                                 I))
                                                                     [COND
                                                                        ((NOT (FMEMB (CAR Z)
                                                                                     FNS))
                                                                         (SETQ FNS
                                                                          (CONS (LISPXPRIN2
                                                                                 (CAR Z)
                                                                                 T T)
                                                                                FNS]
                                                                     (SETQ I (CDDR Z))
                                                                     T]
                         (PROGN (LISPXPRIN2 I T T)
                                (OR (FMEMB FILE OTHERSFILES)
                                    (SETQ OTHERSFILES (CONS FILE OTHERSFILES]
                        (LISPXSPACES 1 T)))
                  (COND
                     (PRINTFLG (LISPXTERPRI T))
                     (T (TERPRI T)))
                  (COND
                     ((NEQ COMS T)
                      (COND
                         ((OR FNS OTHERSFILES)
                          (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS))
                                 FULL EDITPATTERN COMS (NULL OTHERSFILES))
                          (SETQ OTHERSFILES)
                          (SETQ FNS])]
     (COND
        ((EQ COMS T)
         (CONS OTHERSFILES FNS])

(EDITFROMFILE
  [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES)     (* rmk%: "14-Mar-85 21:51")
    (RESETVARS [(EDITLOADFNSFLG (COND
                                   ((EQ EDITLOADFNSFLG T)
                                    '(T . NO))
                                   (T EDITLOADFNSFLG]
               (PROG NIL
                     [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN]
                     (AND
                      (SETQ FILES (for FILE inside (OR FILES FILELST)
                                     when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE)
                                                                             FILELST))
                                                  (COND
                                                     ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" 
                                                                                        FILE)
                                                                    NIL T))
                                                      (LOADFROM FILE FNS 'ALLPROP)
                                                      T))) collect FILE))
                      (for TYPE in [COND
                                              ((LISTP ONLYTYPES))
                                              (ONLYTYPES '(FNS))
                                              (T 

                                 (* ;; "Move FNS to the front.  This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.")

                                                 (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES]
                         when (AND (LITATOM TYPE)
                                       (NEQ (fetch EDITDEF of TYPE)
                                            'NILL))
                         do
                         (PROG (SEEN)
                               (for FILE inside FILES
                                  do
                                  (for NAME in [COND
                                                          ((AND (EQ TYPE 'FNS)
                                                                (NEQ FNS T))
                                                             (* ; 
                                                    "for this type, we are given the list of items")
                                                           (PROG1 FNS (SETQ FNS NIL)))
                                                          (T (* ; 
                             "only want the values of `TYPE' which are not part of some other type")
                                                             (FILECOMSLST FILE TYPE 'EDIT]
                                     unless (MEMBER NAME SEEN)
                                     do
                                     (ERSETQ
                                      (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT
                                                             '(NOCOPY NOERROR))
                                                      (GETDEF NAME TYPE 'SAVED
                                                             '(NOCOPY NOERROR]

                                 (* ;; "If definition has been loaded, it may have been editted.  Work on that explicitly instead of bringing in a file definition to smash the users previous changes.  Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS.  --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file.  But ...  rmk")

                                            (COND
                                               ((OR (AND (EQ TYPE 'FNS)
                                                         (NEQ FNS T))
                                                    (AND (LISTP DEF)
                                                         (LOOKIN DEF EDITPATTERN)))
                                                (COND
                                                   ((NULL SEEN)
                                                    (LISPXPRIN1 "editing the " T)
                                                    (LISPXPRIN1 (OR (fetch DESCRIPTION
                                                                       of TYPE)
                                                                    TYPE)
                                                           T)
                                                    (LISPXSPACES 1 T)))
                                                (SETQ SEEN (CONS NAME SEEN))
                                                (LISPXPRIN2 NAME T T)
                                                (LISPXPRIN1 ":
" T)
                                                (COND
                                                   ((NOT
                                                     (ERSETQ (EDITDEF
                                                              NAME TYPE
                                                              (OR (AND DEF (CONS '= DEF))
                                                                  FILE)
                                                              EDITCOMS)))
                                                    (LISPXPRIN1 "failed" T)))
                                                (LISPXTERPRI T])

(FINDATS
  [LAMBDA (X L)                                          (* lmm "11-FEB-78 16:03")
    (COND
       ((NLISTP X)
        (FMEMB X L))
       (T (OR (FINDATS (CAR X)
                     L)
              (FINDATS (CDR X)
                     L])

(LOOKIN
  [LAMBDA (X PAT)                                        (* lmm "11-MAR-78 14:20")
    (COND
       ([AND (EQ (CAR PAT)
                 '*ANY*)
             (EVERY (CDR PAT)
                    (FUNCTION (LAMBDA (X)
                                (AND (LITATOM X)
                                     (NOT (STRPOS ' X]
        (FINDATS X (CDR PAT)))
       (T (EDITFINDP X PAT T])
)
(DEFINEQ

(SEPRCASE
  [LAMBDA (CLFLG RDTBL)                                  (* bvm%: "24-Oct-86 18:16")

    (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent.  Based on FILERDTBL, but others are close with respect to breaks and seprs")

    (OR RDTBL (SETQ RDTBL FILERDTBL))
    (OR [ARRAYP (CDR (ASSOC RDTBL (COND
                                     (CLFLG CLISPCASEARRAYS)
                                     (T SEPRCASEARRAYS]
        (LET ((CA (CASEARRAY)))
             [if (READTABLEPROP RDTBL 'CASEINSENSITIVE)
                 then                                    (* ; "map upper into lower case")
                       (for I from (CHARCODE A) to (CHARCODE Z)
                          do (SETCASEARRAY CA I (+ I (- (CHARCODE a)
                                                            (CHARCODE A]
             (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS
                                                    collect (CHCON1 Y)))
                                      (GETSEPR RDTBL)
                                      (GETBRK RDTBL)) do (SETCASEARRAY CA X 0))
             (if *PACKAGE*
                 then                                    (* ; 
                               "symbols qualified with package prefix will otherwise be unfindable")
                       (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR)
                              0))
             (SETQ CA (CONS RDTBL CA))
             (COND
                (CLFLG (push CLISPCASEARRAYS CA))
                (T (push SEPRCASEARRAYS CA)))
             (CDR CA])
)

(RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL))

(RPAQ? SEPRCASEARRAYS )

(RPAQ? CLISPCASEARRAYS )

(MOVD? 'INFILEP 'FINDFILE)

                                                             (* ; "or else from SPELLFILE")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
       (NOLINKFNS LOADFROM))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)
)



(* ; "EXPORT")

(DEFINEQ

(IMPORTFILE
  [LAMBDA (FILE RETURNFLG)                               (* lmm " 6-Jun-86 17:43")
    (RESETLST
        [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT]
        (RESETSAVE (INPUT FILE))                             (* ; 
                "Reset INPUT in case some form on the file's action is to read the next expression")
        (NCONC [COND
                  ((EQ RETURNFLG T)                          (* ; 
                                           "Just creating EXPORTS.ALL, don't side-effect the world")
                   (IMPORTFILESCAN FILE RETURNFLG))
                  (T (LET (FILEPKGFLG DFNFLG)
                          (IMPORTFILESCAN FILE RETURNFLG]
               (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE))
                                     ''IMPORTDATE
                                     (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE]
                      RETURNFLG)))])

(IMPORTEVAL
  [LAMBDA (FORM RETURNFLG)                               (* ; "Edited  2-May-87 18:57 by Pavel")

    (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")

    (AND (LISTP FORM)
         (SELECTQ (CAR FORM)
             (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (/DECLAREDATATYPE                               (* ; 
                    "Ignore datatype initializations -- we only need the record declaration itself")
                  NIL)
             (PROGN                                          (* ; "default: eval and/or return it")
                    (AND (NEQ RETURNFLG T)
                         (EVAL FORM))
                    (AND RETURNFLG (LIST FORM])

(IMPORTFILESCAN
  [LAMBDA (FILE RETURNFLG)                               (* bvm%: "24-Oct-86 19:31")
    (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
        (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
           join (until (EQUAL (SETQ DEF (READ FILE))
                                      ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])

(CHECKIMPORTS
  [LAMBDA (FILES NOASKFLG)                               (* rmk%: "19-FEB-83 16:31")
                                                             (* ; 
                                           "Loads exported definitions from new versions of FILES.")
    (COND
       ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE
                            when [AND (SETQ FULLFILENAME (FINDFILE FILE T))
                                          (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE)
                                                                     'IMPORTDATE]
                                              (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 
                                                                     'ICREATIONDATE]
                            collect (LIST FILE FULLFILENAME)))
             (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from "
                                                       (MAPCAR FILES (FUNCTION CAR)))
                                          '((Y "es
")
                                            (N "o
"))
                                          T)
                              (N NIL)
                              T)))
        (for FILE in FILES do (IMPORTFILE (CADR FILE])

(GATHEREXPORTS
  [LAMBDA (FROMFILES TOFILE FLG)                         (* bvm%: "14-Oct-86 23:12")
                                                             (* ; 
                                        "Copies all exported definitions from FROMFILES to TOFILE.")
    (RESETLST
        [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE)
                             (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT]
        (RESETSAVE (OUTPUT TOFILE))
        (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*))
             (SETQ ENV (if ENV
                           then (\DO-DEFINE-FILE-INFO NIL ENV)
                         else *OLD-INTERLISP-READ-ENVIRONMENT*))
             (WITH-READER-ENVIRONMENT ENV
                 (PRINT-READER-ENVIRONMENT ENV)
                 (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T)
                        " ON "
                        (DATE)
                        "%"  T)" T "(LISPXTERPRI T)" T)
                 (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T))
                                                              (FUNCTION PRINT))
                                                       (TERPRI))
                 (PRINT 'STOP)
                 (TERPRI)
                 (FULLNAME TOFILE))))])

(\DUMPEXPORTS
  [NLAMBDA COMS                                          (* bvm%: "24-Oct-86 19:42")

(* ;;; "Dumps an EXPORT form.  IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.")

    (PRIN1 "(")
    (PRIN2 '*)
    (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2))               (* ; 
                                   "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE")
    (for TAIL on COMS do (PRETTYCOM (CAR TAIL)))
    (TERPRI)
    (PRINT ENDEXPORTDEFFORM)
    (TERPRI])
)
(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X])

(RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")

(RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)
)



(* ; "for GAINSPACE")

(DEFINEQ

(CLEARFILEPKG
  [LAMBDA (FLG)                                          (* bvm%: "29-Aug-86 13:02")
    (PROG NIL
          (COND
             ((SELECTQ FLG
                  ((E T) 
                       T)
                  (Y (TERPRI T)
                     (PRIN1 "you can delete just the filemaps -
" T)
                     (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? "
                                   '((Y "es - everything" RETURN T)
                                     (N "o - just the filemaps" RETURN NIL)
                                     (E "verything" RETURN T)
                                     (F "ilemaps only" RETURN NIL]
                            (TERPRI T)))
                  NIL)
              (UPDATEFILES)
              [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE)
                                                        (COND
                                                           ((fetch TOBEDUMPED
                                                               of (fetch FILEPROP
                                                                         of FILE))
                                                            (PRINT FILE T T)
                                                            (PRIN1 " has changes, not wiped." T)
                                                            (TERPRI T)
                                                            T)
                                                           (T (replace FILEPROP of FILE
                                                                 with NIL)
                                                              (replace FILECHANGES of FILE
                                                                 with NIL)
                                                              (SMASHFILECOMS FILE)
                                                              (NCONC1 SYSFILES FILE)
                                                              NIL]
              (SETQ LOADEDFILELST)))
          (SELECTQ FLG
              ((NIL T))
              (CLRHASH *FILEMAP-HASH*])
)

(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                    ((Y "es")
                                     (N "o")
                                     (E . "verything")
                                     (F "ilemaps only%
-"))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SMASHPROPSLST1)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST 
       DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS 
       LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG 
       MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS 
       FILEPKGTYPEPROPS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
       (SPECVARS COMSNAME))

(BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
       (NOLINKFNS . T)
       (SPECVARS COMSNAME)
       (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))

(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS 
       INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
       (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
       INFILECOMSPROP)

(BLOCK%: NIL MAKEFILE (LOCALVARS . T)
       (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))

(BLOCK%: ADDFILE ADDFILE ADDFILE0)

(BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))

(BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
       COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF 
       EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE
       FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES 
       MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED 
       MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
       SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF 
       UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS 
                          EDITLOADFNSFLG LOADOPTIONS)
       (LOCALVARS . T))

(BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))

(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
       GETDEFSAVED (RETFNS GETDEFCOM)
       (NOLINKFNS . T)
       (GLOBALVARS NOT-FOUNDTAG))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS 
                          MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS 
                          PRETTYDEFMACROS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1995 2018 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (22660 24365 (SEARCHPRETTYTYPELST 22670 . 23649) (PRETTYDEFMACROS 23651 . 24109) (
FILEPKGCOMPROPS 24111 . 24363)) (25162 59103 (CLEANUP 25172 . 26560) (COMPILEFILES 26562 . 26838) (
COMPILEFILES0 26840 . 27560) (CONTINUEDIT 27562 . 28982) (MAKEFILE 28984 . 40626) (FILECHANGES 40628
 . 42963) (FILEPKG.MERGECHANGES 42965 . 43788) (FILEPKG.CHANGEDFNS 43790 . 44102) (MAKEFILE1 44104 . 
48374) (COMPILE-FILE? 48376 . 49708) (MAKEFILES 49710 . 51403) (ADDFILE 51405 . 53926) (ADDFILE0 53928
 . 58064) (LISTFILES 58066 . 59101)) (59791 95031 (FILEPKGCHANGES 59801 . 61151) (GETFILEPKGTYPE 61153
 . 64226) (MARKASCHANGED 64228 . 65865) (FILECOMS 65867 . 66251) (WHEREIS 66253 . 67673) (
SMASHFILECOMS 67675 . 67910) (FILEFNSLST 67912 . 68074) (FILECOMSLST 68076 . 68560) (UPDATEFILES 68562
 . 73862) (INFILECOMS? 73864 . 75767) (INFILECOMTAIL 75769 . 76909) (INFILECOMS 76911 . 77072) (
INFILECOM 77074 . 87283) (INFILECOMSVALS 87285 . 87612) (INFILECOMSVAL 87614 . 88616) (INFILECOMSPROP 
88618 . 89447) (IFCPROPS 89449 . 90710) (IFCEXPRTYPE 90712 . 91223) (IFCPROPSCAN 91225 . 92278) (
IFCDECLARE 92280 . 93591) (INFILEPAIRS 93593 . 93925) (INFILECOMSMACRO 93927 . 95029)) (95066 125161 (
FILES? 95076 . 97269) (FILES?1 97271 . 97921) (FILES?PRINTLST 97923 . 98705) (ADDTOFILES? 98707 . 
108628) (ADDTOFILE 108630 . 109546) (WHATIS 109548 . 111524) (ADDTOCOMS 111526 . 113170) (ADDTOCOM 
113172 . 119719) (ADDTOCOM1 119721 . 120892) (ADDNEWCOM 120894 . 121944) (MAKENEWCOM 121946 . 123789) 
(DEFAULTMAKENEWCOM 123791 . 125159)) (125231 128048 (MERGEINSERT 125241 . 127584) (MERGEINSERT1 127586
 . 128046)) (129833 140745 (DELFROMFILES 129843 . 130693) (DELFROMCOMS 130695 . 132374) (DELFROMCOM 
132376 . 138244) (DELFROMCOM1 138246 . 139043) (REMOVEITEM 139045 . 139919) (MOVETOFILE 139921 . 
140743)) (140959 143328 (SAVEPUT 140969 . 143326)) (143453 151777 (UNMARKASCHANGED 143463 . 145171) (
PREEDITFN 145173 . 147684) (POSTEDITPROPS 147686 . 150187) (POSTEDITALISTS 150189 . 151775)) (151926 
172480 (ALISTS.GETDEF 151936 . 152315) (ALISTS.WHENCHANGED 152317 . 152961) (CLEARCLISPARRAY 152963 . 
154137) (EXPRESSIONS.WHENCHANGED 154139 . 154513) (MAKEALISTCOMS 154515 . 155588) (MAKEFILESCOMS 
155590 . 157027) (MAKELISPXMACROSCOMS 157029 . 159047) (MAKEPROPSCOMS 159049 . 159747) (
MAKEUSERMACROSCOMS 159749 . 161549) (PROPS.WHENCHANGED 161551 . 162172) (FILEGETDEF.LISPXMACROS 162174
 . 163616) (FILEGETDEF.ALISTS 163618 . 164237) (FILEGETDEF.RECORDS 164239 . 165170) (FILEGETDEF.PROPS 
165172 . 165964) (FILEGETDEF.MACROS 165966 . 167026) (FILEGETDEF.VARS 167028 . 167444) (FILEGETDEF.FNS
 167446 . 168810) (FILEPKGCOMS.PUTDEF 168812 . 171252) (FILES.PUTDEF 171254 . 172211) (VARS.PUTDEF 
172213 . 172356) (FILES.WHENCHANGED 172358 . 172478)) (174581 182014 (RENAME 174591 . 175992) (
CHANGECALLERS 175994 . 182012)) (182015 229963 (SHOWDEF 182025 . 182818) (COPYDEF 182820 . 185294) (
GETDEF 185296 . 187572) (GETDEFCOM 187574 . 188540) (GETDEFCOM0 188542 . 189888) (GETDEFCURRENT 189890
 . 196310) (GETDEFERR 196312 . 197613) (GETDEFFROMFILE 197615 . 201895) (GETDEFSAVED 201897 . 203001) 
(PUTDEF 203003 . 203706) (EDITDEF 203708 . 204685) (DEFAULT.EDITDEF 204687 . 207523) (EDITDEF.FILES 
207525 . 207726) (LOADDEF 207728 . 207904) (DWIMDEF 207906 . 208760) (DELDEF 208762 . 211776) (
DELFROMLIST 211778 . 212282) (HASDEF 212284 . 218606) (GETFILEDEF 218608 . 219130) (SAVEDEF 219132 . 
220791) (UNSAVEDEF 220793 . 221689) (COMPAREDEFS 221691 . 224993) (COMPARE 224995 . 225699) (TYPESOF 
225701 . 229961)) (230030 235073 (FIXEDITDATE 230040 . 233543) (EDITDATE? 233545 . 235071)) (235492 
244078 (FILEPKGCOM 235502 . 240435) (FILEPKGTYPE 240437 . 244076)) (256111 270613 (FINDCALLERS 256121
 . 256636) (EDITCALLERS 256638 . 264246) (EDITFROMFILE 264248 . 269928) (FINDATS 269930 . 270202) (
LOOKIN 270204 . 270611)) (270614 272341 (SEPRCASE 270624 . 272339)) (272858 278400 (IMPORTFILE 272868
 . 273842) (IMPORTEVAL 273844 . 274724) (IMPORTFILESCAN 274726 . 275147) (CHECKIMPORTS 275149 . 276485
) (GATHEREXPORTS 276487 . 277810) (\DUMPEXPORTS 277812 . 278398)) (278738 280946 (CLEARFILEPKG 278748
 . 280944)))))
STOP
\ No newline at end of file
diff --git a/sources/FILEPKG.~9~ b/sources/FILEPKG.~9~
deleted file mode 100644
index 88375137..00000000
--- a/sources/FILEPKG.~9~
+++ /dev/null
@@ -1,13 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 8-Aug-2020 17:33:31" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;9 283711 

      changes to%:  (FNS EDITCALLERS)

      previous date%: " 7-Mar-2020 14:24:19" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;8)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020 by Venue & Xerox Corporation.  All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")

(PRETTYCOMPRINT FILEPKGCOMS)

(RPAQQ FILEPKGCOMS
       [(COMS                                                (* ; 
            "standard records for accessing file  package type/command parts.  Exported for PRETTY")
              (VARS FILEPKGTYPEPROPS)
              (EXPORT (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS * FILEPKGRECORDS)))
              (FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS FILEPKGCOMPROPS)
              (INITRECORDS * FILEPKGRECORDS))
        [DECLARE%: EVAL@COMPILE DOCOPY 

               (* ;; "Proclaim SPECIAL those variables that are used freely in a lot of code.")

               (P (CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES 
                                       PRETTYPRINTMACROS *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS
                                       PRETTYFLG))
                  (CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES 
                                       NOTCOMPILEDFILES MAKEFILEFORMS CLEANUPOPTIONS]
        (INITVARS (MSDATABASELST))
        [COMS 
              (* ;; "making, adding, listing, compiling files")

              (FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES 
                   FILEPKG.MERGECHANGES FILEPKG.CHANGEDFNS MAKEFILE1 COMPILE-FILE? MAKEFILES ADDFILE
                   ADDFILE0 LISTFILES)
              (INITVARS (*DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)
                     (FILELST)
                     (LOADEDFILELST)
                     (NOTLISTEDFILES)
                     (NOTCOMPILEDFILES)
                     (MAKEFILEFORMS)
                     (NILCOMS))
              (ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% 
                              F ST STF (REC . RC)
                              (BREC . RC)
                              (TC . C)
                              (BC . C)
                              (TCOMPL . C)
                              (BCOMPL . C)))
              (INITVARS (MAKEFILEREMAKEFLG T)
                     (CLEANUPOPTIONS '(RC]
        (COMS 
              (* ;; "scanning file coms")

              (FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS 
                   FILEFNSLST FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM
                   INFILECOMSVALS INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                   IFCDECLARE INFILEPAIRS INFILECOMSMACRO))
        (COMS 
              (* ;; "adding to a file")

              (FNS FILES? FILES?1 FILES?PRINTLST ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM 
                   ADDTOCOM1 ADDNEWCOM MAKENEWCOM DEFAULTMAKENEWCOM)
              (INITVARS (DEFAULTCOMHASFILEFLG))
              (ADDVARS (MARKASCHANGEDFNS))
              (FNS MERGEINSERT MERGEINSERT1)
              
              (* ;; "RMK: Changed INITVARS to VARS, so = addition works")

              (VARS [ADDTOFILEKEYLST (LIST '(%[ "" EXPLAINSTRING 
                                           "[ -- prettyprint the item to terminal and then ask again"
                                                NOECHOFLG T)
                                           '(= "" EXPLAINSTRING "= - same as previous response" 
                                               NOECHOFLG T)
                                           (LIST (CHARACTER (CHARCODE ^J))
                                                 ""
                                                 'EXPLAINSTRING 
                                                 "{line-feed} - same as previous response"
                                                 'NOECHOFLG T)
                                           '(%  " %
-" EXPLAINSTRING "{space} - no action" NOECHOFLG T
                                                )
                                           '(%] "Nowhere%
-" EXPLAINSTRING 
                                                "] - nowhere, item is marked as a dummy%
-" NOECHOFLG
                                                T)
                                           '[%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T 
                                                KEYLST (( "" CONFIRMFLG (%) %] %  %
-)
                                                           RETURN
                                                           (CDR ANSWER]
                                           '(@ "Near: " EXPLAINSTRING 
                                               "@ other-item   -- put the item near the other item" 
                                               NOECHOFLG T KEYLST (( "" CONFIRMFLG (%
-)
                                                                      RETURN ANSWER)))
                                           (LIST (CHARACTER (CHARCODE ^M))
                                                 ""
                                                 'RETURN
                                                 '% )
                                           '("" "File name: " EXPLAINSTRING "a file name" KEYLST
                                                (]
                    (LASTFILE)))
        (COMS 
              (* ;; "deleting an item from a file")

              (FNS DELFROMFILES DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM MOVETOFILE)
              (P (MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)
                 (MOVD? 'MOVETOFILE 'MOVEITEM NIL T))
              (ADDVARS (SYSPROPS PROPTYPE VARTYPE)))
        [COMS                                                (* ; 
                      "functions for doing things and marking them changed and auxiliary functions")
              (FNS SAVEPUT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
                                                     (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT]
              (FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
              (ADDVARS (LISPXFNS (PUT . SAVEPUT)
                              (PUTPROP . SAVEPUT]
        (COMS                                                (* ; 
                                                  "sub-functions for file package commands & types")
              (FNS ALISTS.GETDEF ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED 
                   MAKEALISTCOMS MAKEFILESCOMS MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS 
                   PROPS.WHENCHANGED FILEGETDEF.LISPXMACROS FILEGETDEF.ALISTS FILEGETDEF.RECORDS 
                   FILEGETDEF.PROPS FILEGETDEF.MACROS FILEGETDEF.VARS FILEGETDEF.FNS 
                   FILEPKGCOMS.PUTDEF FILES.PUTDEF VARS.PUTDEF FILES.WHENCHANGED)
              (ADDVARS (MACROPROPS MACRO BYTEMACRO DMACRO)
                     (SYSPROPS PROPTYPE))
              (PROP PROPTYPE I.S.OPR SUBR LIST CODE FILEDATES FILE FILEMAP EXPR VALUE COPYRIGHT 
                    FILETYPE)
              (PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS 
                    LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS 
                    PRETTYPRINTYPEMACROS USERMACROS))
        (COMS                                                (* ; 
                    "Define the commands below AFTER the various properties have been established.")
              (USERMACROS M))
        (COMS                                                (* ; "GETDEF methods")
              (FNS RENAME CHANGECALLERS)
              (FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
                   GETDEFSAVED PUTDEF EDITDEF DEFAULT.EDITDEF EDITDEF.FILES LOADDEF DWIMDEF DELDEF 
                   DELFROMLIST HASDEF GETFILEDEF SAVEDEF UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
              (INITVARS (WHEREIS.HASH)))
                                                             (* ; "Must come after PUTDEF")
        (FNS FIXEDITDATE EDITDATE?)
                                                             (* ; 
                                  "Edit date support for all kinds of definers (from PARC 6/10/92)")
        [VARS (EDITDATE-ARGLIST-DEFINERS '(FUNCTIONS TYPES))
              (EDITDATE-NAME-DEFINERS '(STRUCTURES VARIABLES]
        (GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
        (COMS 
              (* ;; "how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started.")

              (FNS FILEPKGCOM FILEPKGTYPE)
              (PROP ARGNAMES FILEPKGCOM)
              (ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
                     (FILEPKGTYPES FILEPKGCOMS))
              (FILEPKGCOMS FILEPKGCOMS)
              (FILEPKGCOMS ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILEPKGTYPES FILES FILEVARS FNS
                     INITRECORDS INITVARS LISPXCOMS LISPXMACROS MACROS PRETTYDEFMACROS PROPS RECORDS
                     OLDRECORDS SYSRECORDS USERMACROS VARS * CONSTANTS))
        (ADDVARS (SHADOW-TYPES (FUNCTIONS FNS)
                        (VARIABLES VARS CONSTANTS)))
        (INITVARS (SAVEDDEFS))
        (COMS                                                (* ; "EDITCALLERS")
              (FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
              (FNS SEPRCASE)
              [INITVARS (DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL]
              (INITVARS (SEPRCASEARRAYS)
                     (CLISPCASEARRAYS))
              (P (MOVD? 'INFILEP 'FINDFILE)
                                                             (* ; "or else from SPELLFILE"))
              (BLOCKS (EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
                             (NOLINKFNS LOADFROM)))
              (GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS))
        (COMS                                                (* ; "EXPORT")
              (FNS IMPORTFILE IMPORTEVAL IMPORTFILESCAN CHECKIMPORTS GATHEREXPORTS \DUMPEXPORTS)
              (FILEPKGCOMS EXPORT)
              [INITVARS (BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")
                     (ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"]
              (GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM))
        (COMS                                                (* ; "for GAINSPACE")
              (FNS CLEARFILEPKG)
              [ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                              ((Y "es")
                                               (N "o")
                                               (E . "verything")
                                               (F "ilemaps only%
-"]
              (GLOBALVARS SMASHPROPSLST1))
        (GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT 
               DECLARETAGSLST DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 
               I.S.OPRLST LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS 
               MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS 
               SYSPROPS USERMACROS USERRECLST USERWORDS FILEPKGTYPEPROPS)
        (BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
                       (SPECVARS COMSNAME))
               (ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
                      (NOLINKFNS . T)
                      (SPECVARS COMSNAME)
                      (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))
               (INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL 
                      INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN 
                      IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
                      INFILECOMSPROP)
               (NIL MAKEFILE (LOCALVARS . T)
                    (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
               (ADDFILE ADDFILE ADDFILE0)
               (FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
               (NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
                    COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES 
                    EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM 
                    FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL 
                    LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS 
                    MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE 
                    POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
                    SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED 
                    UNSAVEDEF UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS 
                                                 COMPILE.EXT EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
                    (LOCALVARS . T))
               (DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
               (GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
                      GETDEFSAVED (RETFNS GETDEFCOM)
                      (NOLINKFNS . T)
                      (GLOBALVARS NOT-FOUNDTAG)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS 
                               MAKEFILESCOMS MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP 
                               FILEPKGCOMPROPS PRETTYDEFMACROS)
                      (NLAML)
                      (LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES])



(* ; "standard records for accessing file  package type/command parts.  Exported for PRETTY")


(RPAQQ FILEPKGTYPEPROPS (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF CANFILEDEF FILEGETDEF))
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(DECLARE%: EVAL@COMPILE

(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'ADDTOPRETTYCOM]
                           [DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
                                               (T (/REMPROP DATUM 'DELFROMPRETTYCOM]
                           [PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
                                               (T (/REMPROP DATUM 'PRETTYTYPE]
                           [CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
                                  (UNDOABLE (COND
                                               (NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
                                               (T (/REMPROP DATUM 'FILEPKGCONTENTS]
                           (MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
                                  (STANDARD [COND
                                               [NEWVALUE (PUTASSOC DATUM NEWVALUE
                                                                (OR (LISTP (GETTOPVAL 
                                                                                  'PRETTYDEFMACROS))
                                                                    (SETTOPVAL 'PRETTYDEFMACROS
                                                                           (LIST (LIST DATUM]
                                               (T (SETTOPVAL 'PRETTYDEFMACROS
                                                         (REMOVE (FASSOC DATUM (GETTOPVAL
                                                                                'PRETTYDEFMACROS))
                                                                (GETTOPVAL 'PRETTYDEFMACROS]
                                         UNDOABLE
                                         (COND
                                            [NEWVALUE (/PUTASSOC DATUM NEWVALUE
                                                             (OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
                                                                 (/SETTOPVAL 'PRETTYDEFMACROS
                                                                        (LIST (LIST DATUM]
                                            (T (/SETTOPVAL 'PRETTYDEFMACROS
                                                      (REMOVE (FASSOC DATUM (GETTOPVAL 
                                                                                   'PRETTYDEFMACROS))
                                                             (GETTOPVAL 'PRETTYDEFMACROS]
                                                             (* Not an atom record cause want 
                                                           REMPROP on NILs.)
                                                             (* NOTE%: PRETTCOM on PRETTY has 
                                                           open-coded access to the MACRO 
                                                           property.)
                          (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE 
                                       FILEPKGCONTENTS)))

(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED 
                                   HASDEF EDITDEF FILEGETDEF CANFILEDEF)
                            (ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
                                                           (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
                                                           )
                                                    (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
                                                                              DATUM)))
                                                           (STANDARD (SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                      DATUM NEWVALUE)
                                                                                     )
                                                                            NEWVALUE)
                                                                  UNDOABLE
                                                                  (/SETTOPVAL (CAR (
                                                                                  SEARCHPRETTYTYPELST
                                                                                    DATUM NEWVALUE))
                                                                         NEWVALUE)))
                                                    (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
                                                                             DATUM)))
                                                           (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
                                                                               DATUM NEWVALUE))
                                                                       NEWVALUE)))
                                                    (ALLFIELDS NIL (/SETTOPVAL
                                                                    'PRETTYTYPELST
                                                                    (REMOVE (SEARCHPRETTYTYPELST
                                                                             DATUM)
                                                                           (GETTOPVAL 'PRETTYTYPELST]
                                                             (* NOTE%: PRETTYCOM on PRETTY has 
                                                           open-coded access to GETDEF property)
                                   (INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
                                                (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                                                                   (PUT X
                                                                                        'PROPTYPE
                                                                                        'FILEPKGCOMS]
                                         (ADDTOVAR PRETTYTYPELST ))))

(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
                     [ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
                                             (STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
                                                    UNDOABLE
                                                    (/PUTPROP DATUM 'FILE NEWVALUE])

(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))

(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
)

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
)

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(SEARCHPRETTYTYPELST
  [LAMBDA (TYPE FLG)                                     (* rmk%: " 3-JAN-82 22:55")
                                                             (* ; 
                                                           "access functions used by the records")
    (AND (LITATOM TYPE)
         (OR (find X in PRETTYTYPELST suchthat (EQ (CADR X)
                                                               TYPE))
             (COND
                (FLG [/SETTOPVAL 'PRETTYTYPELST (CONS (SETQ FLG (LIST (PACK* 'CHANGED TYPE
                                                                             'LST)
                                                                      TYPE NIL))
                                                      (GETTOPVAL 'PRETTYTYPELST]
                     (OR (LISTP (GETTOPVAL (CAR FLG)))
                         (/SETTOPVAL (CAR FLG)
                                NIL))
                     FLG])

(PRETTYDEFMACROS
  [NLAMBDA ARGS                                          (* lmm " 5-SEP-78 16:16")
                                                             (* ; 
                                                 "included so that old files will continue to load")
    (for X in ARGS collect (FILEPKGCOM (CAR X)
                                              'MACRO
                                              (CDR X])

(FILEPKGCOMPROPS
  [NLAMBDA PROPS
    (MAPC PROPS (FUNCTION (LAMBDA (Y)
                            (OR (MEMB Y SYSPROPS)
                                (SETQ SYSPROPS (CONS Y SYSPROPS)))
                            (PUT Y 'PROPTYPE 'FILEPKGCOMS])
)

(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))

(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)

[PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
       (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
                                          (PUT X 'PROPTYPE 'FILEPKGCOMS]

(ADDTOVAR PRETTYTYPELST )
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL PRETTYDEFMACROS PRETTYTYPELST FILEPKGTYPES PRETTYPRINTMACROS 
                     *DEFAULT-CLEANUP-COMPILER* MARKASCHANGEDFNS PRETTYFLG))

(CL:PROCLAIM '(GLOBAL FILELST SYSFILES LOADEDFILELST NOTLISTEDFILES NOTCOMPILEDFILES MAKEFILEFORMS 
                     CLEANUPOPTIONS))
)

(RPAQ? MSDATABASELST )



(* ;; "making, adding, listing, compiling files")

(DEFINEQ

(CLEANUP
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (PROG (TEM1 TEM2 OPTIONS)
          (COND
             ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
              (SETQ OPTIONS (CAR FILES))
              (SETQ FILES (CDR FILES)))
             (T (SETQ OPTIONS CLEANUPOPTIONS)))
          (RETURN (APPEND (MAKEFILES OPTIONS FILES)
                         (COND
                            ((NOT (MEMB 'LIST OPTIONS))
                             NIL)
                            ((NULL FILES)
                             (LISTFILES))
                            ((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES))
                                                             (* ; 
            "Intersection check because LISTFILES applied to NIL means list all of NOTLISTEDFILES.")
                             (APPLY 'LISTFILES TEM1)))
                         (COND
                            [(NULL (SETQ TEM1 (MEMB 'RC OPTIONS]
                            ((NULL FILES)
                             (COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES)
                                    (CDR TEM1))
                             TEM2)
                            ((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES))
                             (COMPILEFILES0 TEM2 (CDR TEM1))
                             TEM2])

(COMPILEFILES
  [NLAMBDA FILES                                         (* lmm "14-Aug-84 19:17")
    (COND
       ([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
        (COMPILEFILES0 (CDR FILES)
               (CAR FILES)))
       (T (COMPILEFILES0 FILES])

(COMPILEFILES0
  [LAMBDA (FILES OPTIONS)                                (* rmk%: "19-FEB-83 21:59")
    (for X OPTS (RCFLG _ T) on (OR FILES NOTCOMPILEDFILES)
       first (SETQ OPTS (SELECTQ (CAR (LISTP OPTIONS))
                                (C (SETQ RCFLG NIL)
                                   (CDR OPTIONS))
                                (RC (CDR OPTIONS))
                                OPTIONS)) do (MAKEFILE1 (OR (MISSPELLED? (CAR X)
                                                                           70 FILELST NIL X)
                                                                    (CAR X))
                                                        RCFLG OPTS X])

(CONTINUEDIT
  [LAMBDA (FILE)                                         (* bvm%: "30-Aug-86 15:09")
    (PROG (STREAM FL TEM FC ENV)
          (RESETLST
              [RESETSAVE NIL (LIST 'CLOSEF (SETQ STREAM (OPENSTREAM FILE 'INPUT]
              (SETQ FILE (FULLNAME STREAM))
              (SETFILEPTR STREAM 0)
              (CL:MULTIPLE-VALUE-SETQ (ENV FC)
                     (\PARSE-FILE-HEADER STREAM 'RETURN)))
          (COND
             ([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE]
              (LOADFROM FILE)                                (* ; 
                                                           "also calls addfile to notice the file.")
              ))
          (/replace FILECHANGES of FL with (FILECHANGES FC))
          [/replace FILEDATES of FL with
                                            (LIST (create FILEDATEPAIR
                                                         FILEDATE _ (CADR FC)
                                                         DATEFILENAME _ FILE)
                                                  (create FILEDATEPAIR
                                                         FILEDATE _
                                                         [CAR (SETQ TEM (CDR (MEMB 'date%: FC]
                                                         DATEFILENAME _ (CADR TEM]
          (RETURN FILE])

(MAKEFILE
  [LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE)           (* ; "Edited 29-Aug-89 11:46 by bvm")

    (* ;; "OPTIONS: FAST means dump with PRETTYFLG set to NIL;  LIST means list the FILE;  RC means RECOMPILE, C means COMPILEL;  --- for C AND RC assume ST unless next option is F.")

    (PROG ((PRETTYFLG (AND [NOT (MEMB 'FAST (SETQ OPTIONS (MKLIST OPTIONS]
                           PRETTYFLG))
           (*PRINT-BASE* (if (EQ *PRINT-BASE* 8)
                             then 8
                           else                          (* ; "make sure radix is either 8 or 10, because all others don't read in like they print.  Maybe obsolete now with makefile environments")
                                 10))
           FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
          (DECLARE (CL:SPECIAL PRETTYFLG))
          (SETQ FILE (CAR Z))                                (* ; 
                                               "Necessary because FILE might have been misspelled.")
          (SETQ ROOTNAME (CADR Z))                           (* ; "result of (ROOTFILENAME FILE), or if FILE is corrected, result of applying ROOTFILENAME to correct value.")
          (SETQ FILEPROP (CDDR Z))
          (UPDATEFILES)                                  (* ; "Want updating done after file is added to filelst, so any functions that are being dumped are marked as having been dumped.")
          (SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
          (SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
          (SETQ FILETYPE (GETPROP ROOTNAME 'FILETYPE))
      LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
                       (NULL FILEDATES))
              then                                       (* ; 
                   "File has never been loaded and never dumped i.e. user just set up COMS in core")
            elseif [OR (EQMEMB 'NEW OPTIONS)
                           (AND (NULL MAKEFILEREMAKEFLG)
                                (NOT (MEMB 'REMAKE OPTIONS]
              then (COND
                          ((AND (fetch LOADTYPE of FILEPROP)
                                (NEQ T (fetch LOADTYPE of FILEPROP)))
                           (LISPXPRIN2 FILE T T)
                           (LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
                                           (LOADCOMP 
                                                  "the file was loaded for compilation purposes only")
                                           ((compiled Compiled COMPILED) 
                                                " -- only the compiled file has been loaded
")
                                           ((loadfns LOADFNS) 
                                                " -- only some of its symbolics have been loaded
")
                                           (SHOULDNT))
                                  T)
                           (COND
                              ((NEQ (ASKUSER DWIMWAIT 'Y "Go ahead and MAKEFILE anyway? ")
                                    'Y)                      (* ; 
            "E.g. user loads a .com file and then resets the COMS or defines the functons by hand.")
                               (GO OUT)))
                           (/replace LOADTYPE of FILEPROP with NIL)))
                    (SETQ SOURCEFILE NIL)
                    (SETQ REPRINTFNS NIL)
            elseif SOURCEFILE
              then                                       (* ; "source file given")
            elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME T))
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
                                          (AND [NOT (STRING-EQUAL SOURCEFILE (SETQ SOURCEFILE
                                                                              (fetch DATEFILENAME
                                                                                 of (CAR 
                                                                                            FILEDATES
                                                                                             ]
                                               (INFILEP SOURCEFILE)
                                               (EQUAL (FILEDATE SOURCEFILE)
                                                      (fetch FILEDATE of (CAR FILEDATES]
              then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
                    (OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
            elseif [AND (CDR FILEDATES)
                            [SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
                            (EQUAL (FILEDATE SOURCEFILE)
                                   (fetch FILEDATE of (CADR FILEDATES]
              then 

                    (* ;; "prevous version file is gone, drop back to original daddy file and dump everything that has been changed.")

                    (SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
                                         (fetch FILECHANGES of ROOTNAME)))
                    (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
            else (LISPXPRIN1 
                            '"can't find either the previous version or the original version of 
" T)
                  (LISPXPRIN2 FILE T T)
                  (LISPXPRIN1 '", so it will have to be written anew
" T)
                  (SETQ SOURCEFILE NIL)
                  (SETQ REPRINTFNS NIL)
                  (push OPTIONS 'NEW)
                  (SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
                  (GO LP0))
          (COND
             ((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
                                          (LOADCOMP          (* ; 
                                                   "only loaded via LOADCOMP.  Need to do LOADFROM")
                                                    (LIST 'N SOURCEFILE "was loaded with LOADCOMP"
                                                          '- "LOADFROM it to obtain VARS/COMS"))
                                          (Compiled (AND (INFILECOMS? 'DONTCOPY 'DECLARE%:
                                                                (fetch COMSNAME of FILEPROP))
                                                         (LIST 'Y "only compiled version of" ROOTNAME
                                                               
                                        "was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions"
                                                               )))
                                          ((compiled loadfns) 
                                               (LIST 'N "Only some functions from" SOURCEFILE 
                                             "loaded via LOADFNS. Load all other expressions from it"
                                                     ))
                                          NIL)))
              (SELECTQ [ASKUSER DWIMWAIT (CAR Z)
                              (CDR Z)
                              '((Y "es
")
                                (N "o
")
                                (A "bort MAKEFILE
"]
                  (Y (SELECTQ (fetch LOADTYPE of FILEPROP)
                         (LOADCOMP                           (* ; 
                               "file was never actually loaded, just loadcomped.  thus no filecoms")
                                   (LOADFROM SOURCEFILE))
                         (Compiled 

                                 (* ;; "This is going to be a remake.  If it was originally loaded as a compiled file, must first do a LOADFROM in order to get the properties set up by declare: etc.")

                                   (LOADVARS 'DONTCOPY SOURCEFILE)
                                   (/replace LOADTYPE of FILEPROP with 'COMPILED)
                                                             (* ; "So wont have to be done again.")

                                 (* ;; "These are the only DECLARE:'s that are not also on the compiled file.  Note that a DECLARE: DONTEVAL@LOAD will be found and evaluated, but the corresponding expressions won't be evaluated from within the DECLARE:  Not worthwhile to bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like (DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --)")

                                   )
                         ((loadfns compiled) 

                                 (* ;; "This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions may not have been loaded.")

                              (LOADVARS T SOURCEFILE))
                         NIL))
                  (A (GO OUT))
                  NIL)))
          (RESETLST
              [COND
                 ((MEMB 'NOCLISP OPTIONS)
                  (RESETSAVE PRETTYTRANFLG T))
                 ((MEMB 'CLISP%  OPTIONS)
                  (RESETSAVE PRETTYTRANFLG 'BOTH]
              (RESETSAVE %#UNDOSAVES)
              [COND
                 ((OR (MEMB 'CLISPIFY OPTIONS)
                      (MEMB 'CLISP OPTIONS))
                  (RESETSAVE CLISPIFYPRETTYFLG T))
                 ((OR (EQ FILETYPE 'CLISP)
                      (MEMB 'CLISP (LISTP FILETYPE)))
                  (RESETSAVE CLISPIFYPRETTYFLG 'CHANGES]
              (for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
              (SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
                                REPRINTFNS SOURCEFILE CHANGES)))
          (SETQ LASTFILE ROOTNAME)
          (/replace TOBEDUMPED of FILEPROP with NIL)
          (COND
             ((NOT (EQMEMB 'DON'TLIST FILETYPE))
              (pushnew NOTLISTEDFILES ROOTNAME)))
          (COND
             ((NOT (EQMEMB 'DON'TCOMPILE FILETYPE))
              (pushnew NOTCOMPILEDFILES ROOTNAME)))
          [for TAIL OPT on OPTIONS do (SETQ OPT (CAR TAIL))
                                                 (SELECTQ OPT
                                                     (RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                              (MAKEFILE1 FILE T (CDR TAIL))))
                                                     (C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
                                                             (MAKEFILE1 FILE NIL (CDR TAIL))))
                                                     (LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
                                                                (APPLY 'LISTFILES (LIST FILE))))
                                                     (COND
                                                        ((MEMB OPT MAKEFILEOPTIONS))
                                                        ((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL 
                                                                OPTIONS)
                                                         (GO $$LP))
                                                        (T (ERROR "Unrecognized MAKEFILE option" OPT]
          (RETURN FILE)
      OUT (RETURN (LIST FILE "-- MAKEFILE not performed."])

(FILECHANGES
  [LAMBDA (FILE TYPE)                                    (* bvm%: "30-Aug-86 15:08")

    (* ;; "If FILE is a list, it is assumed to be a file-created expressions;  otherwise, the filecreated expression is read from FILE.  If TYPE, returns the list of changed items of that type from the changes expression.  If TYPE=NIL, returns the whole list of typed change-lists")

    (PROG ([FCEXPR (OR (LISTP FILE)
                       (AND FILE (RESETLST
                                     (LET (OLDPTR STREAM)
                                          [if (SETQ STREAM (OPENP FILE 'INPUT))
                                              then (SETQ OLDPTR (GETFILEPTR STREAM))
                                                    (SETFILEPTR STREAM 0)
                                            else (RESETSAVE NIL (LIST 'CLOSEF
                                                                          (SETQ STREAM
                                                                           (OPENSTREAM FILE
                                                                                  'INPUT]
                                          (CL:MULTIPLE-VALUE-BIND (ENV FC)
                                                 (\PARSE-FILE-HEADER STREAM 'RETURN)
                                                 (if OLDPTR
                                                     then (SETFILEPTR STREAM OLDPTR))
                                                 FC)))]
           FNS CHANGES)
          (SETQ CHANGES (LDIFF (SETQ CHANGES (CDR (MEMB 'to%: FCEXPR)))
                               (MEMB 'previous CHANGES)))
          [if (AND TYPE (NEQ TYPE 'FNS))
              then (RETURN (CDR (ASSOC TYPE CHANGES]
          (SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM)))     (* ; 
                         "Old style changes expression listed FNS by name and other things by type")
          (RETURN (if TYPE
                      then                               (* ; "TYPE=FNS cause of test above.")
                            (NCONC FNS (CDR (ASSOC 'FNS CHANGES)))
                    elseif FNS
                      then (CONS (CONS 'FNS FNS)
                                     (SUBSET CHANGES (FUNCTION LISTP)))
                    else CHANGES])

(FILEPKG.MERGECHANGES
  [LAMBDA (C1 C2)                                        (* rmk%: "24-MAY-82 23:09")

    (* ;; "Merges 2 changes lists into a single one.  Treat LITATOM's as FNS, to accomodate old-style format on files.")

    (for E2 TEMP (VAL _ (for E1 in C1 when (CDR (LISTP E1)) collect (APPEND
                                                                                         E1)))
       in C2 do [COND
                           ((SETQ TEMP (ASSOC (CAR E2)
                                              VAL))
                            (NCONC TEMP (for X in (CDR E2) unless (MEMBER X (CDR TEMP))
                                           collect X)))
                           (T (SETQ VAL (NCONC1 VAL (APPEND E2] finally (RETURN VAL])

(FILEPKG.CHANGEDFNS
  [LAMBDA (CHANGES)                                      (* rmk%: "20-MAY-82 22:00")

    (* ;; "Returns list of function names from a file-changes list.  Interprets old format (functions are atoms) and new format (with explicit type headers)")

    (CDR (ASSOC 'FNS CHANGES])

(MAKEFILE1
  [LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES)            (* ; "Edited 29-Aug-89 11:46 by bvm")
    (PROG* ((ROOTNAME (ROOTFILENAME FILE))
            (COMPILER (COMPILE-FILE? ROOTNAME))
            GROUP)
           (COND
              ((AND (OR (EQ COMPILER 'BCOMPL)
                        (EQ COMPILER 'TCOMPL))
                    (NOT (FILEFNSLST ROOTNAME)))         (* ; 
                 "No FNS on this file, and we're told to use Interlisp compiler, so nothing to do.")
               (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES))
               (RETURN NIL)))
           (COND
              ([find X in (SETQ GROUP (GETPROP ROOTNAME 'FILEGROUP))
                  suchthat (AND (NEQ X ROOTNAME)
                                    (OR (fetch TOBEDUMPED of (fetch FILEPROP of
                                                                                         X))
                                        (MEMB X OTHERFILES]

               (* ;; "The file in question must be recompiled with other files, and one of the remaining files still needs to be dumped, or else one of the other file is further down the list of files being compiled.  Wait.")

               (RETURN)))
           (LISPXPRIN1 '"
compiling " T)
           (LISPXPRINT (OR GROUP FILE)
                  T T)
           (LISPXPRINT (LET [[REDEFINE? (OR (EQ (CAR OPTIONS)
                                                'ST)
                                            (EQ (CAR OPTIONS)
                                                'STF]
                             (FORGET-EXPRS? (EQ (CAR OPTIONS)
                                                'STF]
                            (SELECTQ COMPILER
                                ((FAKE-COMPILE-FILE)         (* ; 
                                               "The old CommonLispy interface to the ByteCompiler.")
                                     (FAKE-COMPILE-FILE FILE :REDEFINE REDEFINE? :SAVE-EXPRS
                                            (AND REDEFINE? (NOT FORGET-EXPRS?))))
                                ((CL:COMPILE-FILE)           (* ; "The new, improved (?) compiler")
                                     (CL:COMPILE-FILE FILE :LOAD (COND
                                                                    ((AND REDEFINE? (NOT 
                                                                                        FORGET-EXPRS?
                                                                                         ))
                                                                     :SAVE)
                                                                    (REDEFINE? T)
                                                                    (T NIL))))
                                ((TCOMPL BCOMPL)             (* ; "The old ByteCompiler")
                                     [IF (MEMB (CAR OPTIONS)
                                                   '(ST F S STF))
                                         THEN (LISPXUNREAD (LIST (CAR OPTIONS]
                                     [IF GROUP
                                         THEN 

                                               (* ;; 
                                   "File contained in FILEGROUP.  Therefore must be blockcompiled.")

                                               (IF RECOMPFLG
                                                   THEN (BRECOMPILE GROUP)
                                                 ELSE (BCOMPL GROUP))
                                       ELSEIF (EQ COMPILER 'TCOMPL)
                                         THEN (IF RECOMPFLG
                                                      THEN (RECOMPILE FILE)
                                                    ELSE (TCOMPL (LIST FILE)))
                                       ELSE (IF RECOMPFLG
                                                    THEN (BRECOMPILE FILE)
                                                  ELSE (BCOMPL (LIST FILE])
                                (SHOULDNT "Non-existent compiler returned from COMPILE-FILE?...")))
                  T T])

(COMPILE-FILE?
  [LAMBDA (ROOTNAME)                                     (* ; "Edited 19-Jan-87 21:12 by Pavel")

(* ;;; "Which compiler should CLEANUP use?")

    (LET ((TYPE (GET ROOTNAME 'FILETYPE))
          (UNKNOWN NIL))
         (FOR X INSIDE TYPE DO (SELECTQ X
                                               ((TCOMPL :TCOMPL) 
                                                    (RETURN 'TCOMPL))
                                               ((BCOMPL :BCOMPL) 
                                                    (RETURN 'BCOMPL))
                                               ((:FAKE-COMPILE-FILE CL:COMPILE-FILE COMPILE-FILE) 
                                                    (RETURN 'FAKE-COMPILE-FILE))
                                               ((:COMPILE-FILE :XCL-COMPILE-FILE) 
                                                    (RETURN 'CL:COMPILE-FILE))
                                               ((CLISP) 
                                                    NIL)
                                               (SETQ UNKNOWN T))
            FINALLY (IF UNKNOWN
                            THEN (CL:FORMAT T "~2%%**Warning: unknown FILETYPE value ~S~2%%" TYPE
                                            ))
                  (RETURN *DEFAULT-CLEANUP-COMPILER*])

(MAKEFILES
  [LAMBDA (OPTIONS FILES)                                (* rmk%: "23-FEB-83 21:20")
    (RESETVARS (%#UNDOSAVES)                                 (* ; 
                                                   "Willing to save arbitrary amounts of undo info")
               (UPDATEFILES)
               [COND
                  ((NULL FILES)
                   (for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE
                                                                         (COND
                                                                            ((NULL FLG)
                                                             (* ; "Gets printed the first time")
                                                                             
                                                                             '
                                        "****NOTE: the following are not contained on any file:
    ")
                                                                            (T '"    "]
                      do (SETQ FLG T) finally (AND FLG (ADDTOFILES?]
               (SETQ OPTIONS (MKLIST OPTIONS))
               (RETURN (for FILE inside (OR FILES FILELST)
                          when [fetch TOBEDUMPED of (LISTP (fetch FILEPROP
                                                                          of (ROOTFILENAME FILE]
                          collect (LISPXPRIN2 FILE T T)
                                (LISPXPRIN1 '|...| T)
                                (PROG1 (MAKEFILE FILE OPTIONS)
                                       (LISPXTERPRI T])

(ADDFILE
  [LAMBDA (FILE LOADTYPE PRLST FCLST)                    (* bvm%: "29-Aug-86 12:22")

    (* ;; "PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files compiled into it, for compiled files.")

    (PROG ((ROOTNAME (ROOTFILENAME FILE))
           FLST VAL)
          [COND
             ((NOT FCLST)
              (SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE)))
             [(NULL (CDR FCLST))                             (* ; "A simple symbolic file")
              (SETQ FCLST (CAR FCLST))
              (SETQ VAL (ADDFILE0 (COND
                                         ((LITATOM (CADR FCLST))
                                          (ROOTFILENAME (CADR FCLST)))
                                         (T ROOTNAME))
                               LOADTYPE FILE (CAR FCLST]
             (T 
                (* ;; "A compiled file, skip the first expression representing the compiled file itself, look at the cdr representing the symbolic files.")

                (SELECTQ LOADTYPE
                    ((T LOADFNS) 
                         (SETQ LOADTYPE 'Compiled))
                    (loadfns (SETQ LOADTYPE 'compiled))
                    (LOADCOMP                                (* ; 
                   "loadcomp on compiled file.  Don't notice since we don't know what its state is")
                              NIL)
                    (SHOULDNT))
                (for X in (CDR FCLST) when (LITATOM (CADR X))
                   do (push FLST (CADR X))
                         (OR (EQ LOADTYPE 'LOADCOMP)
                             (ADDFILE0 (ROOTFILENAME (CADR X))
                                    LOADTYPE
                                    (CADR X)
                                    (CAR X]
          (UPDATEFILES PRLST (OR FLST (LIST FILE)))
          [AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES
                           when (AND (LITATOM TYPE)
                                         (SETQ CHANGED (fetch CHANGED of TYPE)))
                           do (/replace CHANGED of TYPE
                                     with (INTERSECTION (CDR (ASSOC TYPE PRLST))
                                                     CHANGED]
          (AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS))
          (RETURN VAL])

(ADDFILE0
  [LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT)               (* lmm "28-Nov-84 16:47")
    (PROG (COMS X FILEPROP FLG TEM)
      TOP (SETQ COMS (FILECOMS ROOTNAME))
          [COND
             ((SETQ FILEPROP (fetch FILEPROP of ROOTNAME))
              (COND
                 ([AND LOADTYPE (FMEMB LOADTYPE
                                       (CDR (FMEMB (fetch LOADTYPE of FILEPROP)
                                                   '(LOADCOMP loadfns compiled Compiled LOADFNS 
                                                           COMPILED NIL T]
                  (/replace LOADTYPE of FILEPROP with LOADTYPE)

                  (* ;; "This call to ADDFILE reflects a 'higher' degree of loading, so upgrade property.  'loadfns' means just some information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files e.g. user does LOADFNS on compiled file.  'Compiled' means all but DECLARE: expressions are in.  e.g. user does LOAD of a compiled file.  COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.  LOADFNS means everything in, e.g. user des LOADFROM symbolic file.  COMPILED and LOADFNS are equivalent in that means dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted.  NIL is a makefile when coms were set up in core.  T is full load of symbolic file.  The check on TYPE=NIL is bcause dont want to upgrade as result of call from makefile, i.e. no new information there.")

                  (* ;; "LOADCOMP means file was loadcomp'ed.  note that the actual structure is a tree, not a list, and the above is only an approximation.  if you do a loadcomp, and then load the compiled file, the state will be left with latter, but then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE expressions, e.g. macros, records etc.  however, in most cases, loadcomp is used independently of other loading, e.g. for compilation purposes only, so this will at least permit loadcomp? to work.")

                  (GO OUT))
                 (T (GO OUT1]
          (COND
             [(OR LOADTYPE (LISTP (GETTOPVAL COMS)))
              (SETQ FILEPROP (/replace FILEPROP of ROOTNAME
                                with (create FILEPROP
                                                COMSNAME _ COMS
                                                LOADTYPE _ LOADTYPE]
             (FLG (GO ERROR))
             ((AND DWIMFLG (EQ ROOTNAME FULLNAME)
                   (SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST T)))

              (* ;; "The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too messy trying to take them out, and then put them back in on the corrected root name.")

              (SETQ FULLNAME ROOTNAME)
              (SETQ FLG T)                                   (* ; 
                                         "so wont try to spelling correct again if file isnt there")
              (GO TOP))
             (T (GO ERROR)))
      OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME
                               with (LIST (create FILEDATEPAIR
                                                     FILEDATE _ DAT
                                                     DATEFILENAME _ FULLNAME]
          (AND (EQ LOADTYPE T)
               (/replace TOBEDUMPED of FILEPROP with NIL))
      OUT1
          [COND
             ([AND (LISTP (GETTOPVAL COMS))
                   (NOT (FMEMB ROOTNAME (GETTOPVAL 'FILELST] (* ; 
                                                          "coms wuld not be set up on a loadccomp.")
              (/SETTOPVAL 'FILELST (CONS ROOTNAME (GETTOPVAL 'FILELST]
          (RETURN (COND
                     ((NULL LOADTYPE)                        (* ; "call from makefile.")
                      (CONS FULLNAME (CONS ROOTNAME FILEPROP)))
                     (T FILEPROP)))
      ERROR
          (ERROR FULLNAME "not file name." T])

(LISTFILES
  [NLAMBDA FILES                                         (* rmk%: " 3-Dec-84 08:58")
    (DECLARE (GLOBALVARS NOTLISTEDFILES))                (* ; "LISTFILES1 is machinedependent")
    (for FILE FULLNAME OPTIONS in (COND
                                             (FILES (SETQ FILES (NLAMBDA.ARGS FILES)))
                                             (T NOTLISTEDFILES))
       when (COND
                   ((LISTP FILE)
                    (SETQ OPTIONS (APPEND FILE OPTIONS))
                    NIL)
                   ((SETQ FULLNAME (FINDFILE FILE))
                    FULLNAME)
                   (T (printout T FILE " not found." T)
                      NIL)) collect [COND
                                           ((LISTFILES1 FULLNAME OPTIONS)
                                            (SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
                                                                        NOTLISTEDFILES]
                                  FULLNAME])
)

(RPAQ? *DEFAULT-CLEANUP-COMPILER* 'CL:COMPILE-FILE)

(RPAQ? FILELST )

(RPAQ? LOADEDFILELST )

(RPAQ? NOTLISTEDFILES )

(RPAQ? NOTCOMPILEDFILES )

(RPAQ? MAKEFILEFORMS )

(RPAQ? NILCOMS )

(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP%  F ST STF
                                 (REC . RC)
                                 (BREC . RC)
                                 (TC . C)
                                 (BC . C)
                                 (TCOMPL . C)
                                 (BCOMPL . C))

(RPAQ? MAKEFILEREMAKEFLG T)

(RPAQ? CLEANUPOPTIONS '(RC))



(* ;; "scanning file coms")

(DEFINEQ

(FILEPKGCHANGES
  [LAMBDA N                                              (* Pavel " 7-Oct-86 19:22")
    (COND
       [(EQ N 0)
        (PROG (TEM)
              (RETURN (for X in FILEPKGTYPES when (AND (LITATOM X)
                                                                   (SETQ TEM (FILEPKGCHANGES
                                                                              X)))
                         collect (CONS X TEM]
       [(EQ (ARG N 1)
            T)
        (for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES
                                                                                 X]
       [(EQ N 1)
        (COND
           [(LISTP (ARG N 1))
            (for X in (ARG N 1) when (FMEMB (CAR X)
                                                        FILEPKGTYPES)
               do (/replace CHANGED of (CAR X) with (CDR X]
           (T (for Y on (fetch CHANGED of (ARG N 1))
                 when [AND (CAR Y)
                               (NOT (for Z in (CDR Y) thereis (CL:EQUAL (CAR Y)
                                                                                 Z]
                 collect (CAR Y]
       (T (/replace CHANGED of (ARG N 1) with (ARG N 2])

(GETFILEPKGTYPE
  [LAMBDA (TYPE ONLY NOERROR NAME)                       (* lmm "20-Nov-86 23:10")

    (* ;; "Coerce TYPE to a well defined definition type (FILEPKG type) or a command. ONLY is an indicator of which is acceptable; if NIL, either one is acceptable, if COMS, only commands are acceptable, and if TYPES, only types should be returned. If none is found, will signal an error if NOERROR is NIL, otherwise return NIL. ")

    (COND
       [(LISTP TYPE)

        (* ;; " given a list of types, coerce them all or return NIL")

        (for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME)
                                               (RETURN]
       ((EQ TYPE '?)

        (* ;; "odd case, may be obsolete: if given IL:?, return all known types of NAME. Maybe used by EDITDEF(NAME ?)?? ")

        (AND NAME (TYPESOF NAME)))
       [(AND (NEQ ONLY 'COMS)
             (OR (SELECTQ TYPE
                     (NIL 'FNS)
                     (T 'VARS)
                     NIL)
                 (for X in FILEPKGTYPES do (if (EQ TYPE X)
                                                           then 

                                                                 (* ;; "type matched exactly")

                                                                 (RETURN TYPE)
                                                         elseif (AND (LISTP X)
                                                                         (EQ TYPE (CAR X)))
                                                           then (RETURN (CDR X]
       [(AND (NEQ ONLY 'TYPE)
             (LITATOM TYPE)
             (PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST))       (* ; "Prefer an exact match quickly")
                    ]
       [(AND (NEQ ONLY 'COMS)
             (LITATOM TYPE)
             (for X in FILEPKGTYPES bind NAME
                do (SETQ NAME (if (NLISTP X)
                                      then X
                                    else (CAR X))) 

                      (* ;; "see if spelled the same or 1 char shorter; assume all FILEPKGTYPE names end with S. This handles package conversions and also pluralization")

                      (AND (<= 0 (- (NCHARS NAME)
                                    (NCHARS TYPE))
                               1)
                           (STRPOS TYPE NAME)
                           (RETURN (if (EQ X NAME)
                                       then X
                                     else (CDR X]
       [(FIXSPELL TYPE NIL (SELECTQ ONLY
                               (TYPE FILEPKGTYPES)
                               (COMS FILEPKGCOMSPLST)
                               (UNION FILEPKGTYPES FILEPKGCOMSPLST]
       ((NOT NOERROR)
        (ERROR (SELECTQ ONLY
                   (TYPE "unrecognized manager definition type")
                   (COMS "unrecognized manager command")
                   "unrecognized manager definition-type/command")
               TYPE])

(MARKASCHANGED
  [LAMBDA (NAME TYPE REASON)                             (* ; "Edited 25-May-88 15:37 by drc:")
    (COND
       (FILEPKGFLG (SETQ REASON (SELECTQ REASON
                                    ((CLISP LOAD CHANGED DEFINED DELETED) 
                                         REASON)
                                    (NIL 'CHANGED)
                                    (T 'DEFINED)
                                    (ERROR "bad REASON in MARKASCHANGED" REASON)))
              (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (for FN inside (fetch WHENCHANGED of TYPE)
                 do (APPLY* FN NAME TYPE REASON))
              (for FN in MARKASCHANGEDFNS do (APPLY* FN NAME TYPE REASON))
              [COND
                 ((EQ REASON 'DELETED)
                  (for L on (fetch CHANGED of TYPE) when (EQUAL (CAR L)
                                                                                    NAME)
                     do (/RPLACA L NIL))                 (* ; 
                                                          "unmark as changed and remove from files")
                  (DELFROMFILES NAME TYPE))
                 (T (LET ((LST (push (fetch CHANGED of TYPE)
                                      NAME)))
                         (AND LISPXHIST (UNDOSAVE (LIST '/RPLACA LST)
                                               LISPXHIST))   (* ; 
                             "UNDO by smashing with NIL;  makes calls to MARKASCHANGED independent")
                         ]
              NAME])

(FILECOMS
  [LAMBDA (FILE X)                                       (* rmk%: "19-FEB-83 13:55")
    (COND
       ((AND (NULL FILE)
             (NULL X))
        'NILCOMS)
       [(AND (OR (NULL X)
                 (EQ X 'COMS))
             (fetch COMSNAME of (LISTP (fetch FILEPROP of FILE]
       (T (PACK* (NAMEFIELD FILE)
                 (OR X 'COMS])

(WHEREIS
  [LAMBDA (NAME TYPE FILES FN)                        (* ; "Edited 12-Jul-88 17:14 by MASINTER")

    (* ;; "T as a NAME has a special meaning to INFILECOMS?  so don't pass through.")

    (CL:UNLESS (EQ NAME T)
        (LET [(IN-FILES (UNION [SUBSET (OR (LISTP FILES)
                                           FILELST)
                                      (FUNCTION (LAMBDA (FILE)
                                                  (INFILECOMS? NAME TYPE (FILECOMS FILE]
                               (AND (EQ FILES T)
                                    (CL:FBOUNDP 'XCL::HASH-FILE-WHERE-IS)
                                    (LET ((FILES NIL))
                                         (for TY inside TYPE
                                            do (for FILE-NAME
                                                      in (XCL::HASH-FILE-WHERE-IS NAME
                                                                    (GETFILEPKGTYPE TYPE))
                                                      do (CL:PUSHNEW (MKATOM (U-CASE FILE-NAME))
                                                                    FILES)))
                                         (REVERSE FILES]
             (CL:IF FN
                 [MAPC IN-FILES (FUNCTION (LAMBDA (FILE)
                                            (APPLY* FN NAME FILE]
                 IN-FILES)))])

(SMASHFILECOMS
  [LAMBDA (FILE)                                         (* rmk%: "19-FEB-83 22:15")
    (for X in (FILECOMSLST FILE 'FILEVARS) when (LITATOM X)
       do (SETTOPVAL X 'NOBIND))
    FILE])

(FILEFNSLST
  [LAMBDA (FILE)                                         (* ; "Edited 14-Jun-90 19:30 by jds")
    (FILECOMSLST FILE '(FUNCTIONS FNS])

(FILECOMSLST
  [LAMBDA (FILE TYPE FLG)                                (* JonL "24-Jul-84 19:48")
                                                             (* ; 
                                                    "TYPE is coerced in the innards of INFILECOMS?")
    (COND
       ((EQ FLG 'UPDATE)
        (CDR (INFILECOMS? NIL TYPE (FILECOMS FILE)
                    FLG)))
       (T (INFILECOMS? NIL TYPE (FILECOMS FILE)
                 FLG])

(UPDATEFILES
  [LAMBDA (PRLST FLST)                                   (* rmk%: "19-FEB-83 14:27")

    (* ;; "PRLST may be the value of FILEPKGCHANGES before some operation (e.g.  LOAD, LOADFNS) involving the files in FLST began.")

    (for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE))
       do (COND
                 ((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE)))
                                                             (* ; 
                                                           "FILEPKGCHANGES eliminates duplicates")
                  (/replace CHANGED of TYPE with NIL))
                 (T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES
                           (PREVITEMS _ (CDR (ASSOC TYPE PRLST))) in FILELST
                       first (SETQ LST (INFILECOMS? CHANGED TYPE 'NILCOMS 'UPDATE)) 

                             (* ;; "First check NIL=Nowhere.  LST:1 contains variables whose values are on the file literally.  These are `found' but not marked.  LST::1 contains all other items.")

                             (SETQ FOUND (NCONC (CAR LST)
                                                (CDR LST)
                                                FOUND))
                       do (SETQ PCHANGES (COND
                                                ((FMEMB (fetch DATEFILENAME
                                                           of (CAR (fetch FILEDATES
                                                                          of FILE)))
                                                        FLST)

                                 (* ;; "PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this LOAD/LOADFNS began.  Thus, by this intersection we only worry about items that were previously changed;  any items that were only changed during this operation are ignored.")

                                                 (INTERSECTION CHANGED PREVITEMS))
                                                (T CHANGED)))
                             [COND
                                ([AND PCHANGES [SETQ COMS (fetch COMSNAME
                                                             of (SETQ FILEPROP
                                                                     (LISTP (fetch FILEPROP
                                                                               of FILE]
                                      (SETQ LST (INFILECOMS? PCHANGES TYPE COMS 'UPDATE]

                                 (* ;; "LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values are not in the coms")

                                 [COND
                                    ((CDR LST)               (* ; "CDR items must be distributed")
                                     [COND
                                        ((NULL (fetch TOBEDUMPED of FILEPROP))

                                         (* ;; "Only finagle global lists the first time an item is added to PROP, when PROP::1 goes from NIL to non-NIL")

                                         [/SETTOPVAL 'NOTLISTEDFILES (REMOVE FILE (GETTOPVAL
                                                                                   'NOTLISTEDFILES]
                                         (/SETTOPVAL 'NOTCOMPILEDFILES (REMOVE FILE
                                                                              (GETTOPVAL 
                                                                                     '
                                                                                     NOTCOMPILEDFILES
                                                                                     ]
                                                             (* ; 
                                                   "Get the (possibly new) TYPE item list to smash")
                                     [COND
                                        [(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED
                                                                        of FILEPROP]
                                        (T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE]
                                                             (* ; 
                                                        "Now distribute items to the file property")
                                     (for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP)
                                                                                   )
                                        do (/NCONC1 TYPEDPROP Y]
                                 (SETQ FOUND (NCONC (CAR LST)
                                                    (CDR LST)
                                                    FOUND] finally (/replace CHANGED
                                                                          of TYPE
                                                                          with (LDIFFERENCE
                                                                                    CHANGED FOUND])

(INFILECOMS?
  [LAMBDA (NAME TYPE COMS ONFILETYPE)                 (* ; "Edited 12-Jul-88 17:42 by MASINTER")

    (* ;; "Returns T if NAME is 'CONTAINED' in COMS.  If NAME is NIL, then value is a list of all of the functions contained in COMS.  If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL (this feature is used for deciding whether or not (and how) to compile files.)  Called by FILEFNSLST (which is used by BRECOMPILE) and by NEWFILE1.  while elements are the subset of NAME which are on the file in other case")

    (* ;; "if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS?  returns the dotted pair of (literals  . elements) where literals are those which are `literally' on the file (e.g.  (VARS (X 3))) --- if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on the file literally and which are not subparts of other types are returned")

    (* ;; "if ONFILETYPE is TYPESOF, type can be a list of types, and returns a list of types suitable for EDITDEF ")

    (PROG (VAL LITERALS ORIGFLG)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (SELECTQ ONFILETYPE
              (EDIT (SELECTQ TYPE
                        (FILEVARS (RETURN))
                        NIL))
              NIL)
          [COND
             ((LITATOM COMS)
              (SELECTQ TYPE
                  ((VARS FILEVARS)                           (* ; 
                                                           "the COMS of a file are also on it")
                       (INFILECOMSVAL COMS))
                  NIL)
              (SETQ COMS (EVALV COMS]
          (INFILECOMS COMS)
          (SETQ VAL (DREVERSE VAL))
          (RETURN (COND
                     ((EQ ONFILETYPE 'UPDATE)
                      (CONS LITERALS VAL))
                     (T VAL])

(INFILECOMTAIL
  [LAMBDA (COM FLG)                                   (* ; "Edited  2-Aug-88 02:15 by masinter")
    [SETQ COM (COND
                 ((EQ (CADR COM)
                      '*)
                  (COND
                     [(LITATOM (CADDR COM))
                      (LISTP (EVALV (CADDR COM]
                     (T [RESETVARS (DWIMLOADFNSFLG)
                                   (NLSETQ (SETQ COM (EVAL (CADDR COM]
                        COM)))
                 (T (CDR COM]
    (if (NOT FLG)
        then (for X in COM
                    do [if (AND (LISTP X)
                                        (EQ (CAR X)
                                            COMMENTFLG))
                               then (RETURN (SUBSET COM (FUNCTION (LAMBDA (X)
                                                                        (OR (NLISTP X)
                                                                            (NEQ (CAR X)
                                                                                 COMMENTFLG]
                    finally (RETURN COM))
      else COM])

(INFILECOMS
  [LAMBDA (COMS)                                         (* rmk%: "19-FEB-83 22:17")
    (for X in COMS do (INFILECOM X])

(INFILECOM
  [LAMBDA (COM)                                       (* ; "Edited  2-Aug-88 02:27 by masinter")
    (COND
       [(NLISTP COM)
        (COND
           ((EQ TYPE 'VARS)
            (INFILECOMSVAL COM]
       ((EQ (CAR COM)
            COMMENTFLG)

        (* ;; 
"must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
                                                             (* ; 
  "don't know why I should bother, but someone might want to know all of the comments on a file???")
        (COND
           ((EQ TYPE COMMENTFLG)
            (INFILECOMSVAL COM T)))
        NIL)
       (T
        (PROG ((COMNAME (CAR COM))
               (TAIL (CDR COM))
               CFN TEM)
              (COND
                 [[COND
                     ((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
                      (SETQ TEM (APPLY* CFN COM (COND
                                                   ((AND (NULL ONFILETYPE)
                                                         (NOT (CL:SYMBOLP NAME)))
                                                             (* ; 
                                                "call from WHEREIS of a name which is not a symbol")
                                                    (LIST NAME))
                                                   (T NAME))
                                       TYPE ONFILETYPE)))
                     ((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
                                                             (* ; "for compatability")
                      (SETQ TEM (APPLY* CFN COM TYPE NAME]
                  (COND
                     [(NLISTP TEM)
                      (COND
                         ((EQ TEM T)
                          (COND
                             ((OR (EQ NAME T)
                                  (NULL ONFILETYPE))
                              (RETFROM 'INFILECOMS? T]
                     (T (INFILECOMSVALS TEM]
                 ((LISTP TAIL)

                  (* ;; "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")

                  (SELECTQ COMNAME
                      ((PROP IFPROP) 
                           (SETQ TAIL (CDR TAIL)))
                      NIL)
                  [COND
                     ((EQ (CAR TAIL)
                          '*)
                      (COND
                         ((LITATOM (CADR TAIL))
                          (SELECTQ TYPE
                              ((VARS FILEVARS) 
                                   (INFILECOMSVAL (CADR TAIL)))
                              NIL))
                         ((AND (LISTP (CADR TAIL))
                               (EQ ONFILETYPE 'UPDATE)
                               (EQ TYPE 'VARS)
                               (EQ (CAADR TAIL)
                                   'PROGN)
                               (FMEMB (CAR (LAST (CADR TAIL)))
                                      NAME))
                          (SETQ VAL (CONS (CADR TAIL)
                                          VAL]
                  (SELECTQ COMNAME
                      ((COMS EXPORT) 
                           (INFILECOMS (INFILECOMTAIL COM T)))
                      (CL:EVAL-WHEN (INFILECOMS (INFILECOMTAIL (CDR COM)
                                                           T)))
                      (DECLARE%:                             (* ; "skip over DECLARE: tags")
                                 [RETURN (AND (NOT (FMEMB 'COMPILERVARS COM))
                                              (IFCDECLARE (INFILECOMTAIL COM)
                                                     (EQ TYPE 'DECLARE%:])
                      (ORIGINAL                              (* ; "dont expand macros")
                                (PROG ((ORIGFLG T))
                                      (INFILECOMS (INFILECOMTAIL COM T))))
                      ((PROP IFPROP)                         (* ; 
                                       "this currently does not handle `pseudo-types' of PROPNAMES")
                           (SELECTQ TYPE
                               (PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM)
                                                              T)
                                             (CADR COM)))
                               (MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
                                              (CADR COM)))
                               NIL))
                      (PROPS (RETURN (IFCPROPS COM)))
                      (MACROS (RETURN (SELECTQ TYPE
                                          (PROPS (IFCPROPSCAN (INFILECOMTAIL COM T)
                                                        MACROPROPS))
                                          (MACROS (INFILECOMSVALS (INFILECOMTAIL COM T)))
                                          NIL)))
                      (ALISTS                                (* ; 
                      "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")
                              (RETURN (SELECTQ TYPE
                                          (ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
                                          NIL)))
                      (P [RETURN (SELECTQ TYPE
                                     ((EXPRESSIONS P) 
                                          (INFILECOMSVALS (INFILECOMTAIL COM T)
                                                 T))
                                     (COND
                                        ((NULL ONFILETYPE)   (* ; "for WHEREIS and FILECOMSLST")
                                         (SELECTQ TYPE
                                             (I.S.OPRS (IFCEXPRTYPE COM 'I.S.OPR))
                                             (TEMPLATES (IFCEXPRTYPE COM 'SETTEMPLATE))
                                             NIL])
                      ((ADDVARS APPENDVARS) 
                           (SELECTQ TYPE
                               (VARS [RETURN (AND (NULL ONFILETYPE)
                                                  (for X in (INFILECOMTAIL COM T)
                                                     do (INFILECOMSVAL (CAR X)
                                                                   T])
                               (ALISTS [RETURN (for X in (INFILECOMTAIL COM T)
                                                  when (EQMEMB 'ALIST (GETPROP (CAR X)
                                                                                 'VARTYPE))
                                                  do (for Z in (CDR X)
                                                            do (INFILECOMSVAL
                                                                    (LIST (CAR X)
                                                                          (CAR Z))
                                                                    T])
                               (OR (EQ TYPE COMNAME)
                                   (RETURN))))
                      ((VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY) 
                           [RETURN (COND
                                      ((EQ TYPE 'EXPRESSIONS)
                                       (for X in (INFILECOMTAIL COM T)
                                          when (AND (LISTP X)
                                                        (NEQ (CAR X)
                                                             COMMENTFLG))
                                          do (INFILECOMSVAL (CONS 'SETQ X)
                                                        T)))
                                      ((OR (EQ TYPE 'VARS)
                                           (EQ TYPE COMNAME))(* ; 
                   "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")
                                       (for X in (INFILECOMTAIL COM T)
                                          do (COND
                                                    ((LISTP X)
                                                     (AND (CAR X)
                                                          (NEQ (CAR X)
                                                               COMMENTFLG)
                                                          (INFILECOMSVAL (CAR X)
                                                                 T)))
                                                    (X (INFILECOMSVAL X (EQ COMNAME 'INITVARS])
                      (DEFS [RETURN (for X in (INFILECOMTAIL COM T)
                                       when (EQ TYPE (CAR X)) do (INFILECOMSVALS
                                                                          (CDR X])
                      (FILES (RETURN))
                      NIL)

                  (* ;; "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")

                  (COND
                     ((EQ COMNAME TYPE)
                      (INFILECOMSVALS (INFILECOMTAIL COM T)))
                     [(AND (LISTP TYPE)
                           (FMEMB COMNAME TYPE))
                      (LET ((TYPE COMNAME))
                           (INFILECOMSVALS (INFILECOMTAIL COM T]
                     ((AND (OR (NULL CFN)
                               (AND (EQ CFN T)
                                    (NULL ONFILETYPE)))
                           (NULL ORIGFLG)
                           (SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
                      (INFILECOMS (SUBPAIR (CAR TEM)
                                             (INFILECOMTAIL COM T)
                                             (CDR TEM])

(INFILECOMSVALS
  [LAMBDA (X FLG)                                     (* ; "Edited  2-Aug-88 02:21 by masinter")
    (for Y in X when (NOT (AND (LISTP Y)
                                           (EQ (CAR Y)
                                               COMMENTFLG))) do (INFILECOMSVAL Y FLG])

(INFILECOMSVAL
  [LAMBDA (X FLG)                                     (* ; "Edited 12-Jul-88 17:56 by MASINTER")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND (OR (NULL NAME)
                 (MEMBER X NAME))
             (COND
                (FLG (SETQ LITERALS (CONS X LITERALS)))
                (T (SETQ VAL (CONS X VAL]
       ((AND (EQ ONFILETYPE 'EDIT)
             FLG)                                            (* ; 
                                        "literals should not be edited as they are on the fileCOMS")
        NIL)
       ((EQ ONFILETYPE 'TYPESOF)
        (AND (COND
                ((LITATOM NAME)
                 (EQ NAME X))
                (T (EQUAL NAME X)))
             (CL:PUSHNEW TYPE VAL)))
       ([OR (EQ NAME T)
            (COND
               ((LITATOM NAME)
                (EQ NAME X))
               (T (EQUAL NAME X]
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS X VAL])

(INFILECOMSPROP
  [LAMBDA (AT PROP)                                      (* lmm "25-SEP-81 17:15")
    (COND
       [(EQ ONFILETYPE 'UPDATE)
        (AND [OR (NULL NAME)
                 (find X in NAME suchthat (AND (EQ (CAR X)
                                                               AT)
                                                           (EQ (CADR X)
                                                               PROP]
             (SETQ VAL (CONS (LIST AT PROP)
                             VAL]
       ((OR (EQ NAME T)
            (AND (EQ (CAR NAME)
                     AT)
                 (EQ (CADR NAME)
                     PROP)))
        (RETFROM (FUNCTION INFILECOMS?)
               T))
       ((NULL NAME)
        (SETQ VAL (CONS (LIST AT PROP)
                        VAL])

(IFCPROPS
  [LAMBDA (COM)                                          (* bvm%: " 2-Dec-83 14:24")

(* ;;; "Examine a PROPS com for objects of specified TYPE")

    (SELECTQ TYPE
        (PROPS                                               (* ; 
                                       "the PROPS command can actually take (PROPNAME at1 at2 ...)")
               (INFILEPAIRS (INFILECOMTAIL COM)))
        (PROP                                                (* ; 
                                                "return the atoms which have any properties at all")
              (for PAIR in (INFILECOMTAIL COM) do (for ATNAME
                                                                     inside (CAR PAIR)
                                                                     do (INFILECOMSVAL ATNAME
                                                                                   ))))
        (MACROS                                              (* ; "only MACRO properties")
                (for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR)
                                                                           (CDR PAIR))))
        NIL])

(IFCEXPRTYPE
  [LAMBDA (COM FN)                                       (* ; "Edited  6-Apr-87 20:20 by Pavel")

(* ;;; "Recognizes expressions in COM (a P com) that are calls to function FN")

    (for SUBCOM in (INFILECOMTAIL COM)
       when (AND (EQ (CAR SUBCOM)
                         FN)
                     (EQ (CAR (LISTP (CADR SUBCOM)))
                         'QUOTE)) do (INFILECOMSVAL (CADR (CADR SUBCOM))
                                                T])

(IFCPROPSCAN
  [LAMBDA (ATOMS PROPNAMES)                           (* ; "Edited  2-Aug-88 02:20 by masinter")

(* ;;; 
"Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES")

    (for AT in ATOMS WHEN (LITATOM AT) unless [COND
                                                                 [(EQ ONFILETYPE 'UPDATE)
                                                                  (COND
                                                                     (NAME (NOT (ASSOC AT NAME]
                                                                 ((LISTP NAME)
                                                                  (NEQ AT (CAR NAME]
       do (COND
                 ((EQ PROPNAMES 'ALL)
                  (for PROP in (GETPROPLIST AT) by (CDDR PROP)
                     when (NOT (FMEMB PROP SYSPROPS)) collect (INFILECOMSPROP AT PROP)))
                 (T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])

(IFCDECLARE
  [LAMBDA (TAIL WANTDECLARE)                          (* ; "Edited  8-Jun-90 18:11 by teruuchi")
    (PROG ((TAIL TAIL))
      LP  (COND
             ((LISTP TAIL)
              [SELECTQ (CAR TAIL)
                  ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                       [AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
                                                                 (CADR TAIL]
                       (SETQ TAIL (CDR TAIL)))
                  (DONTEVAL@LOAD [COND
                                    ((OR (\STKSCAN 'DOFILESLOAD)
                                         (\STKSCAN 'LOAD))
                                                  (* ; "Edited by TT (8-June-90 : for AR#9376) In loading, discard the following contents in DECLARE tag %"DONTEVAL@LOAD%"")
                                     (RETURN))
                                    (WANTDECLARE (INFILECOMSVAL (CAR TAIL])
                  (COMPILERVARS (RETURN))
                  (COND
                     [(FMEMB (CAR TAIL)
                             DECLARETAGSLST)
                      (COND
                         (WANTDECLARE (INFILECOMSVAL (CAR TAIL]
                     (T (INFILECOM (CAR TAIL]
              (SETQ TAIL (CDR TAIL))
              (GO LP])

(INFILEPAIRS
  [LAMBDA (LST)                                          (* lmm " 4-DEC-78 09:51")
    (for LL in LST do (for X inside (CAR LL)
                                     do (for Y inside (CDR LL)
                                               do (INFILECOMSVAL (LIST X Y])

(INFILECOMSMACRO
  [LAMBDA (ATS PROPS)                                    (* lmm "28-SEP-78 18:35")

    (* ;; "this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.  --- Normally (e.g.  for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the given atom.  However, for UPDATE, it only wants a `hit' if the command contains ALL of the macro properties")

    (for AT inside ATS do (AND [OR (NEQ ONFILETYPE 'UPDATE)
                                               (EVERY (PROPNAMES AT)
                                                      (FUNCTION (LAMBDA (X)
                                                                  (OR (NOT (FMEMB X MACROPROPS))
                                                                      (EQMEMB X PROPS]
                                           [SOME MACROPROPS (FUNCTION (LAMBDA (PROP)
                                                                        (EQMEMB PROP PROPS]
                                           (INFILECOMSVAL AT])
)



(* ;; "adding to a file")

(DEFINEQ

(FILES?
  [LAMBDA NIL                                            (* bvm%: "27-Oct-86 18:14")

(* ;;; 
"Display each file needing dumping, etc.  For files needing dumping, display details of why.")

    (UPDATEFILES)
    (LET (FILES CHANGES PRINTED)
         (for FILE in FILELST when [SETQ CHANGES (fetch TOBEDUMPED
                                                                of (LISTP (fetch FILEPROP
                                                                                 of FILE]
            do (if (NOT PRINTED)
                       then (LISPXPRIN1 "To be dumped:
" T)
                             (SETQ PRINTED T))
                  (LISPXPRIN2 FILE T)
                  (LISPXPRIN1 " ...changes to " T)
                  [for CH in CHANGES bind TB
                     do (COND
                               ((LISTP CH)
                                [COND
                                   (TB (LISPXTAB TB NIL T))
                                   (T (SETQ TB (POSITION T]
                                (LISPXPRIN2 (CAR CH)
                                       T)
                                (FILES?PRINTLST (CDR CH)))
                               (T                            (* ; "old style")
                                  (LISPXPRIN2 CH T)
                                  (LISPXSPACES 1 T]
                  (LISPXTERPRI T))
         (for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND PRINTED "    plus "))
            do (SETQ FLG T) finally (if FLG
                                                then (OR PRINTED (LISPXPRIN1 "...to be dumped.  "
                                                                            T))
                                                      (ADDTOFILES?)))
         (if (SETQ FILES NOTCOMPILEDFILES)
             then (FILES?PRINTLST FILES "To be compiled: ")
                   (LISPXTERPRI T))
         (if (SETQ FILES NOTLISTEDFILES)
             then (FILES?PRINTLST FILES "To be listed: ")
                   (LISPXTERPRI T))
         (CL:VALUES])

(FILES?1
  [LAMBDA (TYPE FIRST)                                   (* bvm%: "27-Oct-86 18:17")

    (* ;; "If there are changed objects of TYPE, then print them out, preceded by FIRST (if given) plus a descriptive string, and return T.")

    (LET (STR LST)
         (COND
            ([AND (LITATOM TYPE)
                  (SETQ STR (fetch DESCRIPTION of TYPE))
                  (LISTP (SETQ LST (fetch CHANGED of TYPE]
             (AND FIRST (LISPXPRIN1 FIRST T))
             (LISPXPRIN1 '"the " T)
             (LISPXPRIN1 STR T)
             (FILES?PRINTLST LST)
             (LISPXTERPRI T)
             T])

(FILES?PRINTLST
  [LAMBDA (LST STR)                                      (* bvm%: "27-Oct-86 18:15")

    (* ;; "Print elements of LST separated by commas and indenting new lines a bunch.  If MAPRINT had a left margin arg, this would be simpler.")

    (MAPRINT LST T (OR STR ": ")
           NIL ", " [FUNCTION (LAMBDA (STR)
                                (COND
                                   ((> (+ (POSITION T)
                                          (NCHARS STR T T)
                                          3)
                                       (LINELENGTH NIL T))
                                    (LISPXTERPRI T)
                                    (LISPXPRIN1 "         " T)))
                                (LISPXPRIN2 STR T T]
           T])

(ADDTOFILES?
  [LAMBDA (NOASKSTR)                                     (* ; "Edited 21-Aug-91 10:13 by jds")

    (* ;; "ask user about all of the things that need to be dumped, and distribute them to the files that he says")

    (ERSETQ
     (PROG [BUFS (VARSCHANGES (fetch (FILEPKGTYPE CHANGED) of 'VARS]

      (* ;; "Save VARS list at the beginning, so that changes that might occur from adding things to files (e.g.  changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES")

           [COND
              (NOASKSTR (PRIN1 NOASKSTR T))
              (T (DOBE)
                 (SETQ BUFS (READP T))
                 (SELECTQ (ASKUSER DWIMWAIT 'N '("want to say where the above go")
                                 '((Y "es
")
                                   (N "o
")
                                   (%] "Nowhere
" EXPLAINSTRING "] - nowhere, all items will be marked as dummy
" NOECHOFLG T))
                                 T)
                     (N (RETURN))
                     (%] (for TYPE in FILEPKGTYPES
                            do (for NAME in (fetch (FILEPKGTYPE CHANGED)
                                                           of TYPE)
                                      do (ADDTOFILE NAME TYPE NIL)))
                         (RETURN))
                     NIL)                                    (* ; 
                              "if there was type-ahead BEFORE the askuser, then don't allow it now")
                 (COND
                    (BUFS (SETQ BUFS (COND
                                        ((READP T)
                                         (LINBUF)
                                         (SYSBUF)
                                         (SETQ BUFS (CLBUFS NIL T READBUF]
           [for TYPE STR LST in FILEPKGTYPES
              when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
                            (LISTP (SETQ LST (COND
                                                ((EQ TYPE 'VARS)
                                                 VARSCHANGES)
                                                (T (fetch (FILEPKGTYPE CHANGED) of TYPE]
              do
              (printout T "(" STR ")" T)
              (for NAME TEM FILE in LST when NAME
                 do
                 (PROG NIL
                   LP  (PRIN2 NAME T)
                       (SPACES 2 T)

                  (* ;; "if user typed ahead before entering addtofiles??  then dont allow typeahead here, because it will justgobble his earlier typeahead.")

                       (SELECTQ (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T))
                           (%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)

                                 (* ;; "the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that the control-E will merely clear output buffer")

                                              (DOBE)))
                               (GO LP))
                           (%] (SETQ FILE))
                           (%                                (* ; "space.  means no action")
                               (RETURN))
                           (%
 (PRINT (OR (SETQ FILE LASTFILE)
            'Nowhere)
        T))
                           (SETQ FILE TEM))
                       (OR (ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
                                         (SETQ PLACE (WHATIS FILE NIL TYPE))
                                         [COND
                                            ((LITATOM PLACE) (* ; "file name")
                                             (SETQ FILE PLACE)
                                             (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                                                        NAME TYPE NEAR LISTNAME)
                                                 (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                          (* ;; "This isn't factored to the end, cause ADDTOLISTNAME might have to deal with a set of old elements on the listname.")

                                             )
                                            ((EQ (CAR PLACE)
                                                 'Near%:)
                                             (SETQ NEAR (CADR PLACE))
                                             (COND
                                                ([SOME FILELST (FUNCTION (LAMBDA (FL)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           FL))
                                                                            NAME TYPE NEAR LISTNAME]
                                                 (PRINT (LIST 'on FILE)
                                                        T T))
                                                (T (PRINT (LIST (CADR PLACE)
                                                                'not
                                                                'found)
                                                          T T)
                                                   (ERROR!)))
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE)))
                                            ([OR [UNDONLSETQ (PROGN (SAVESET
                                                                     (SETQ LISTNAME (CAR PLACE))
                                                                     (MERGEINSERT
                                                                      NAME
                                                                      (LISTP (GETTOPVAL LISTNAME))
                                                                      T)
                                                                     T
                                                                     'NOPRINT)
                                                                    (OR (SETQ FILE
                                                                         (CAR (WHEREIS NAME TYPE
                                                                                     FILELST)))
                                                                        (ERROR!]
                                                 (SOME FILELST (FUNCTION (LAMBDA (X)
                                                                           (ADDTOCOMS
                                                                            (FILECOMS (SETQ FILE
                                                                                           X))
                                                                            NAME TYPE NEAR LISTNAME]
                                             (PRIN1 "  value is filed on " T)
                                             (PRINT FILE T T)
                                             (for F in (fetch WHENFILED of TYPE)
                                                do (APPLY* F NAME TYPE FILE))

                                 (* ;; "Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list already belong and were previously noticed")

                                             )
                                            (T (PRIN1 "    put list " T)
                                               (PRIN2 (CAR PLACE)
                                                      T T)
                                               (SETQ FILE
                                                (WHATIS (ASKUSER NIL NIL " on file: "
                                                                   '(("" "" EXPLAINSTRING 
                                                                         "a file name" KEYLST ()))
                                                                   T)
                                                       'FILE))
                                               (SAVESET (CAR PLACE)
                                                      (MERGEINSERT NAME
                                                             (LISTP (GETTOPVAL (CAR PLACE)))
                                                             T)
                                                      T
                                                      'NOPRINT)

                                     (* ;; "Add new item before new command, so that user's new command function can inspect (CAR PLACE) and see all the items involved.")

                                               (ADDNEWCOM (FILECOMS FILE)
                                                      NAME TYPE (CAR PLACE)
                                                      FILE)
                                               (for F in (fetch WHENFILED of TYPE)
                                                  do (for I in (GETTOPVAL (CAR PLACE))
                                                            do (APPLY* F I TYPE FILE]
                                         (AND FILE (ADDFILE FILE))
                                         (SETQ LASTFILE PLACE)))
                           (GO LP]
           (AND BUFS (BKBUFS BUFS))
           (UPDATEFILES])

(ADDTOFILE
  [LAMBDA (NAME TYPE FILE NEAR LISTNAME)                 (* lmm "21-Nov-84 11:43")
                                                             (* ; "adds NAME to the file FILE")
    (PROG (TEM COMSNAME)
          [SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T)
                         (COND
                            ((FMEMB TYPE FILELST)
                             (GETFILEPKGTYPE (swap TYPE FILE)))
                            (T (GETFILEPKGTYPE TYPE]
          (SETQ FILE (WHATIS FILE 'FILE))
          (OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
                     NAME TYPE NEAR LISTNAME)
              (ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
          (for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))
          (AND FILE (NOT (FMEMB FILE FILELST))
               (ADDFILE FILE))
          (RETURN FILE])

(WHATIS
  [LAMBDA (USERINPUT ONLY)                               (* lmm "28-Nov-84 16:49")

    (* ;; "decides whether USERINPUT is a file or a list name --- if ONLY is nil, means either a listname or a filename is accepatble;  if ONLY is LIST then only a listname is acceptable and if ONLY is FILE then only a file name is acceptable")

    (PROG (TEM UCASE)
          (RETURN (COND
                     ((NULL USERINPUT)                       (* ; "nowhere")
                      NIL)
                     [(LISTP USERINPUT)
                      (COND
                         (ONLY (ERROR!))
                         (T (SELECTQ (CAR USERINPUT)
                                ((@ Near%:) 
                                     (CONS 'Near%: (CDR USERINPUT)))
                                (WHATIS (CAR USERINPUT)
                                       'LIST]
                     ([AND (NEQ ONLY 'LIST)
                           (OR (FMEMB (SETQ TEM (SETQ UCASE (U-CASE USERINPUT)))
                                      FILELST)
                               (LISTP (GETTOPVAL (FILECOMS UCASE)))
                               (SETQ TEM (FIXSPELL UCASE NIL FILELST T]
                      TEM)
                     ((AND (NEQ ONLY 'FILE)
                           (LISTP (GETTOPVAL USERINPUT)))
                      (LIST USERINPUT))
                     ((AND (NEQ ONLY 'LIST)
                           (EQ (ASKUSER NIL NIL (LIST "create new file" UCASE)
                                      NIL T)
                               'Y))
                      UCASE)
                     ((AND (NEQ ONLY 'FILE)
                           (EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT)
                                      NIL T)
                               'Y))
                      (LIST USERINPUT))
                     (T                                      (* ; "none of above")
                        (ERROR!])

(ADDTOCOMS
  [LAMBDA (COMS NAME TYPE NEAR LISTNAME)                 (* rmk%: "10-JUN-82 22:53")

    (* ;; "try to insert NAME of type TYPE command list COMS (either a coms name, or a just a list of coms);  return NIL if unsuccessful.  If LISTNAME is given, then only insert by adding to LISTNAME.  If NEAR is given, only insert near it")

    (COND
       ((NULL COMS)
        NIL)
       [(LITATOM COMS)                                       (* ; 
      "given a name of a command;  rebind COMSNAME to current variable and try to add to its value")
        (OR [PROG ((COMSNAME COMS))
                  (RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME))
                                 NAME TYPE NEAR (AND (NEQ COMS LISTNAME)
                                                     LISTNAME]
            (AND (EQ COMS LISTNAME)
                 (ADDNEWCOM COMS NAME TYPE]
       (T (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (for TAIL on COMS do (COND
                                              [(LISTP (CAR TAIL))
                                               (COND
                                                  ((ADDTOCOM (CAR TAIL)
                                                          NAME TYPE NEAR LISTNAME)
                                                   (RETURN T]
                                              (T (SELECTQ (CAR TAIL)
                                                     ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                                                          (SETQ TAIL (CDR TAIL)))
                                                     NIL])

(ADDTOCOM
  [LAMBDA (COM NAME TYPE NEAR LISTNAME)                  (* ; "Edited  2-May-87 19:04 by Pavel")
                                                             (* ; 
                        "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful")
    (PROG (TEM)
          (COND
             ([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM]
              (RETURN)))
          [COND
             ((SETQ TEM (fetch ADD of (CAR COM)))
              (RETURN (COND
                         ((OR (NULL LISTNAME)
                              (INFILECOMS? LISTNAME 'FILEVARS (LIST COM)))
                          (AND (SETQ TEM (APPLY* TEM COM NAME TYPE NEAR))
                               (MARKASCHANGED COMSNAME 'VARS))
                          TEM]
          (RETURN
           (SELECTQ (CAR COM)
               (FNS (AND (EQ TYPE 'FNS)
                         (ADDTOCOM1 COM NAME NEAR LISTNAME)))
               ((VARS INITVARS) 
                    (COND
                       ((OR (EQ (CAR COM)
                                'VARS)
                            NEAR LISTNAME)                   (* ; 
                                  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.")
                        (SELECTQ TYPE
                            (EXPRESSIONS (COND
                                            ((EQ (CAR NAME)
                                                 'SETQ)
                                             (ADDTOCOM1 COM (CDR NAME)
                                                    NEAR LISTNAME))))
                            (VARS (ADDTOCOM1 COM NAME NEAR LISTNAME))
                            NIL))))
               (COMS (ADDTOCOMS (COND
                                       [(EQ (CADR COM)
                                            '*)
                                        (COND
                                           ((LITATOM (CADDR COM))
                                            (CADDR COM))
                                           (T (RETURN]
                                       (T (CDR COM)))
                            NAME TYPE NEAR LISTNAME))
               (DECLARE%: (AND (OR LISTNAME NEAR)
                               (ADDTOCOMS (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     ((LITATOM (CADDR COM))
                                                      (CADDR COM))
                                                     (T (RETURN]
                                                 (T (CDR COM)))
                                      NAME TYPE NEAR LISTNAME)))
               (CL:EVAL-WHEN (AND (OR LISTNAME NEAR)
                                  (ADDTOCOMS (COND
                                                    [(EQ (CL:THIRD COM)
                                                         '*)
                                                     (COND
                                                        ((LITATOM (CL:FOURTH COM))
                                                         (CL:FOURTH COM))
                                                        (T (RETURN]
                                                    (T (CDDR COM)))
                                         NAME TYPE NEAR LISTNAME)))
               ((PROP IFPROP) 
                    (SELECTQ TYPE
                        (PROPS (COND
                                  ((EQ (CADR COM)
                                       (CADR NAME))
                                   (ADDTOCOM1 (CDR COM)
                                          (CAR NAME)
                                          NEAR LISTNAME))
                                  ((AND (EQ (CAR NAME)
                                            (CADDR COM))
                                        (NULL (CDDDR COM)))
                                   [/RPLACA (CDR COM)
                                          (UNION (MKLIST (CDR NAME))
                                                 (MKLIST (CADR COM]
                                   (MARKASCHANGED COMSNAME 'VARS)
                                   T)))
                        (MACROS (COND
                                   ([AND (for PROP inside (CADR COM)
                                            always (EQMEMB PROP MACROPROPS))
                                         (for PROP in MACROPROPS
                                            always (OR (EQMEMB PROP (CADR COM))
                                                           (NOT (GETPROP NAME PROP]

                                    (* ;; "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")

                                    (ADDTOCOM1 (CDR COM)
                                           NAME NEAR LISTNAME))))
                        NIL))
               ((PROPS ALISTS) 
                    (AND (EQ TYPE (CAR COM))
                         (ADDTOCOM1
                          COM
                          (/NCONC1 (OR [ASSOC (CAR NAME)
                                              (COND
                                                 [(EQ (CADR COM)
                                                      '*)
                                                  (COND
                                                     [(LITATOM (CADDR COM))
                                                      (AND (OR (NULL LISTNAME)
                                                               (EQ (CADDR COM)
                                                                   LISTNAME))
                                                           (GETTOPVAL (CADDR COM]
                                                     (T (RETURN]
                                                 (T (CDR COM]
                                       (LIST (CAR NAME)))
                                 (CADR NAME))
                          NEAR LISTNAME)))
               (P (COND
                     ((AND (EQ TYPE 'EXPRESSIONS)
                           (NEQ (CAR NAME)
                                'SETQ))
                      (ADDTOCOM1 COM NAME NEAR LISTNAME))))
               (AND (EQ (CAR COM)
                        TYPE)
                    (ADDTOCOM1 COM NAME NEAR LISTNAME])

(ADDTOCOM1
  [LAMBDA (COM NAME NEAR LISTNAME)                       (* rmk%: " 3-JAN-82 22:53")
    (COND
       [(EQ (CADR COM)
            '*)                                              (* ; "add to list name")
        (AND [COND
                (LISTNAME (EQ (CADDR COM)
                              LISTNAME))
                (T (LITATOM (CADDR COM]
             (SAVESET (CADDR COM)
                    [PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM]
                           (COND
                              ((AND NEAR (SETQ NEAR (MEMBER NEAR COM)))
                               (/RPLACD NEAR (CONS NAME (CDR NEAR)))
                               COM)
                              (T (MERGEINSERT NAME COM T]
                    T
                    'NOPRINT]
       ((NULL LISTNAME)                                      (* ; "add to standard com")
        [AND (NOT (MEMBER NAME (CDR COM)))
             (COND
                [(SETQ NEAR (MEMBER NEAR COM))
                 (/RPLACD NEAR (CONS NAME (CDR NEAR]
                (T (/RPLACD COM (MERGEINSERT NAME (CDR COM]
        (MARKASCHANGED COMSNAME 'VARS)
        T])

(ADDNEWCOM
  [LAMBDA (COMSNAME NAME TYPE LISTNAME FILE)             (* rmk%: " 3-JAN-82 22:53")

    (* ;; "Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE.  --- if LISTNAME is given, then use it as the listname")

    (PROG (NEWCOM OLDCOM TAIL)
          (SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE))
          [COND
             ((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME)))
              (RETURN (SAVESET COMSNAME (LIST NEWCOM)
                             T
                             'NOPRINT]
      LP  [COND
             ((OR (NLISTP (SETQ OLDCOM (CAR TAIL)))
                  (SELECTQ (CAR OLDCOM)
                      ((LOCALVARS SPECVARS BLOCKS) 
                           T)
                      (DECLARE%: (FMEMB 'COMPILERVARS (CDR OLDCOM)))
                      NIL))
              (/ATTACH NEWCOM TAIL))
             ((LISTP (CDR TAIL))
              (SETQ TAIL (CDR TAIL))
              (GO LP))
             (T (/RPLACD TAIL (LIST NEWCOM]
          (MARKASCHANGED COMSNAME 'VARS])

(MAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* ; "Edited  8-Apr-87 14:55 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    (PROG (TEM)

     (* ;; "the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef) and (b) if LISTNAME is given, then use it rather than generating a different listname")

          (AND (LISTP NAME)
               (SETQ NAME (COPY NAME)))
          (RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE))
                           (APPLY* TEM NAME TYPE LISTNAME FILE))
                      (SELECTQ TYPE
                          (PROPS [AND (NULL LISTNAME)
                                      (CONS 'PROP (CONS (COND
                                                           ((AND (LISTP (CDR NAME))
                                                                 (NULL (CDDR NAME)))
                                                            (CADR NAME))
                                                           (T (CDR NAME)))
                                                        (OR (LISTP (CAR NAME))
                                                            (LIST (CAR NAME])
                          (EXPRESSIONS [COND
                                          ((EQ (CAR NAME)
                                               'SETQ)
                                           (MAKENEWCOM (CDR NAME)
                                                  'VARS LISTNAME FILE))
                                          (T (CONS 'P (COND
                                                         (LISTNAME (LIST '* LISTNAME))
                                                         (T (LIST NAME])
                          NIL)
                      (DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE])

(DEFAULTMAKENEWCOM
  [LAMBDA (NAME TYPE LISTNAME FILE)                      (* lmm "20-OCT-82 22:48")
    (COND
       ((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST)
                 (fetch MACRO of TYPE)
                 (fetch GETDEF of TYPE)))
        (ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION
                                                                            of TYPE)
                                                                         TYPE)
               T))
       ((NULL DEFAULTCOMHASFILEFLG)                          (* ; "disable FOOFNS FOOVARS junk")
        (LIST TYPE NAME))
       ((EQ FILE T)                                          (* ; 
                                                           "FILE=T only when called from SHOWDEF")
        (LIST TYPE NAME))
       ([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE))
                                      (MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME))
                                             T)
                                      T
                                      'NOPRINT]              (* ; "The check (AND FILE --) is so that it will not bother with making listnames just for deleting items")
        (LIST TYPE '* LISTNAME))
       (T (LIST TYPE NAME])
)

(RPAQ? DEFAULTCOMHASFILEFLG )

(ADDTOVAR MARKASCHANGEDFNS )
(DEFINEQ

(MERGEINSERT
  [LAMBDA (NEW LST ONEFLG)                               (* lmm "30-Jun-86 18:11")

    (* ;; "searches LST to find the most reasonable place to insert NEW.  Does nothing if ONEFLG is T and NEW is already a member of LST")

    (COND
       ((AND ONEFLG (MEMBER NEW LST))
        LST)
       ((LISTP NEW)
        (/NCONC1 LST NEW))
       (T (PROG ((N 0)
                 LST1 PLACE TEM)
                (SETQ LST1 LST)
            LP  

           (* ;; "finds the function with the longest leading common substring.  The idea is that if the list is only paatially sorted, want to insert the new thing in among those function that look like they are related.")

                (COND
                   ((NULL LST1)
                    (GO OUT))
                   ((OR (LISTP (CAR LST1))
                        (SETQ TEM (STRPOS (CAR LST1)
                                         NEW 1 NIL T T)))

                    (* ;; "this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE), ADDTOFILE1 will be inserted aater ADDTOFILE")

                    (SETQ PLACE LST1)
                    (GO OUT))
                   ((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1)
                                                NEW))
                           N)
                    (SETQ N TEM)
                    (SETQ PLACE LST1)))
                (SETQ LST1 (CDR LST1))
                (GO LP)
            OUT (SETQ TEM (CAR PLACE))
                (OR [SOME (OR PLACE LST)
                          (FUNCTION (LAMBDA (X LST)
                                      (COND
                                         ([OR (ALPHORDER NEW X)
                                              (AND PLACE (NOT (ALPHORDER TEM X]

                                 (* ;; "for example, if the FNS list is something like (...  FOO FOO1 ...) where the ...  may or may not be in order, e.g.  (ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before BLAH in a sorted list.")

                                          (/ATTACH NEW LST))
                                         (T (SETQ TEM X)
                                            NIL]
                    (SETQ LST (/NCONC1 LST NEW)))
                (RETURN LST])

(MERGEINSERT1
  [LAMBDA (X Y)                                          (* rmk%: "24-MAY-82 00:05")

    (* ;; "value is the number of leading characters of X and Y that agree.")

    (PROG ((N 1)
           C1 C2)
      LP  [COND
             ((OR (NULL (SETQ C1 (NTHCHARCODE X N)))
                  (NULL (SETQ C2 (NTHCHARCODE Y N)))
                  (NEQ C1 C2))
              (RETURN (SUB1 N]
          (SETQ N (ADD1 N))
          (GO LP])
)



(* ;; "RMK: Changed INITVARS to VARS, so = addition works")


(RPAQ ADDTOFILEKEYLST
      [LIST '(%[ "" EXPLAINSTRING "[ -- prettyprint the item to terminal and then ask again" 
                 NOECHOFLG T)
            '(= "" EXPLAINSTRING "= - same as previous response" NOECHOFLG T)
            (LIST (CHARACTER (CHARCODE ^J))
                  ""
                  'EXPLAINSTRING "{line-feed} - same as previous response" 'NOECHOFLG T)
            '(%  " %
-" EXPLAINSTRING "{space} - no action" NOECHOFLG T)
            '(%] "Nowhere%
-" EXPLAINSTRING "] - nowhere, item is marked as a dummy%
-" NOECHOFLG T)
            '[%( "List:  (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
                 (( "" CONFIRMFLG (%) %] %  %
-)
                     RETURN
                     (CDR ANSWER]
            '(@ "Near: " EXPLAINSTRING "@ other-item   -- put the item near the other item" NOECHOFLG
                T KEYLST (( "" CONFIRMFLG (%
-)
                             RETURN ANSWER)))
            (LIST (CHARACTER (CHARCODE ^M))
                  ""
                  'RETURN
                  '% )
            '("" "File name: " EXPLAINSTRING "a file name" KEYLST (])

(RPAQQ LASTFILE NIL)



(* ;; "deleting an item from a file")

(DEFINEQ

(DELFROMFILES
  [LAMBDA (NAME TYPE FILES)                              (* rmk%: " 6-MAR-82 13:16")

    (* ;; "Eliminates NAME as an item of type TYPE in COMS.")

    (PROG (COMS)
          (SETQ TYPE (GETFILEPKGTYPE TYPE))
          (RETURN (for FILE inside (OR FILES FILELST)
                     when (PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE))
                                            NAME TYPE)
                                  (COND
                                     ((INFILECOMS? NAME TYPE COMS)
                                      (printout T "(could not delete " NAME " from " FILE ")" T))))
                     collect (for FN in (fetch WHENUNFILED of TYPE)
                                    do (APPLY* FN NAME TYPE FILE))
                           FILE])

(DELFROMCOMS
  [LAMBDA (COMS NAME TYPE)                               (* bvm%: " 1-Oct-86 22:02")

    (* ;; "delete NAME of type TYPE from the coms COMS (either the name of some coms or a list).  Returns T if it does anything")

    (* ;; "If COMS is not a symbol, caller is required to bind COMSNAME to the symbol whose value we are deleting from, for benefit of marking it changed.")

    (COND
       [(LITATOM COMS)
        (LET ((COMSNAME COMS))
             (DECLARE (SPECVARS COMS))
             (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME)))
                  (DELFROMCOMS COMS NAME TYPE]
       (T (PROG (DONE)
                (SETQ TYPE (GETFILEPKGTYPE TYPE))
            LP  (COND
                   ((NLISTP COMS)
                    (RETURN DONE)))
                [COND
                   ((LISTP (CAR COMS))
                    (SELECTQ (DELFROMCOM (CAR COMS)
                                    NAME TYPE)
                        (ALL (/RPLNODE2 COMS (CDR COMS))
                             (SETQQ DONE ALL)
                             (GO LP))
                        (NIL)
                        (SETQ DONE T)))
                   (T (SELECTQ (CAR COMS)
                          ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) 
                               (SETQ COMS (CDR COMS)))
                          (COND
                             ((AND (EQ TYPE 'VARS)
                                   (EQ NAME (CAR COMS)))
                              (/RPLNODE2 COMS (CDR COMS))
                              (SETQ DONE T)
                              (GO LP]
                (SETQ COMS (CDR COMS))
                (GO LP])

(DELFROMCOM
  [LAMBDA (COM NAME TYPE)                                (* ; "Edited  2-May-87 19:02 by Pavel")
                                                             (* ; "Tries to delete NAME from COM")
    (PROG (TEM VAR NEW)
          (COND
             ((SETQ TEM (fetch DELETE of (CAR COM)))
              (AND (SETQ TEM (APPLY* TEM COM NAME TYPE))
                   (MARKASCHANGED COMSNAME 'VARS))
              (RETURN TEM)))
          (RETURN (SELECTQ (CAR COM)
                      ((DECLARE%: COMS) 
                           (DELFROMCOMS (COND
                                               [(EQ (CADR COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CADDR COM))
                                                    (CADDR COM))
                                                   (T (RETURN]
                                               (T (CDR COM)))
                                  NAME TYPE))
                      ((CL:EVAL-WHEN) 
                           (DELFROMCOMS (COND
                                               [(EQ (CL:THIRD COM)
                                                    '*)
                                                (COND
                                                   ((LITATOM (CL:FOURTH COM))
                                                    (CL:FOURTH COM))
                                                   (T (RETURN]
                                               (T (CDDR COM)))
                                  NAME TYPE))
                      ((ALISTS PROPS) 
                           (AND (EQ TYPE (CAR COM))
                                (COND
                                   ((EQ (CADR COM)
                                        '*)
                                    (COND
                                       ([AND (LITATOM (SETQ VAR (CADDR COM)))
                                             (SETQ TEM (ASSOC (CAR NAME)
                                                              (GETTOPVAL VAR)))
                                             (NEQ (CDR TEM)
                                                  (SETQ TEM (REMOVEITEM (CADR NAME)
                                                                   (CDR TEM]
                                        (SAVESET VAR TEM T 'NOPRINT)
                                        T)))
                                   ([AND [CDR (SETQ TEM (ASSOC (CAR NAME)
                                                               (CDR COM]
                                         (NEQ (CDR TEM)
                                              (SETQ NEW (REMOVEITEM (CADR NAME)
                                                               (CDR TEM]
                                    (/RPLACD TEM NEW)
                                    (MARKASCHANGED COMSNAME 'VARS)
                                    T))))
                      (BLOCKS 
                              (* ;; "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")

                              [AND (EQ TYPE 'FNS)
                                   (for BLOCK in (INFILECOMTAIL COM T)
                                      do (AND (MEMB NAME BLOCK)
                                                  (/DREMOVE NAME BLOCK))
                                            (for X in BLOCK
                                               when (AND (LISTP X)
                                                             (MEMB NAME (CDR X)))
                                               do (/RPLACD X (REMOVE NAME (CDR X])
                      ((PROP IFPROP) 
                           [SELECTQ TYPE
                               (PROPS (RETURN (COND
                                                 ((EQ (CADR COM)
                                                      (CADR NAME))
                                                  (DELFROMCOM1 (CDR COM)
                                                         (CAR NAME)))
                                                 ((AND (EQMEMB (CADR NAME)
                                                              (CADR COM))
                                                       [NULL (CDR (SETQ TEM (PRETTYCOM1 (CDR COM]
                                                       (EQ (CAR TEM)
                                                           (CAR NAME)))
                                                  [/RPLACA (CDR COM)
                                                         (REMOVE (CADR NAME)
                                                                (MKLIST (CADR COM]
                                                  (MARKASCHANGED COMSNAME 'VARS)
                                                  T))))
                               (COND
                                  ([for PROP inside (CADR COM)
                                      always (EQ TYPE (GETPROP PROP 'PROPTYPE]
                                   (DELFROMCOM1 (CDR COM)
                                          NAME])
                      ((RECORDS INITRECORDS SYSRECORDS) 
                           (AND (EQ TYPE 'RECORDS)
                                (DELFROMCOM1 COM NAME)))
                      (P (AND (EQ TYPE 'EXPRESSIONS)
                              (DELFROMCOM1 COM NAME)))
                      ((VARS INITVARS) 
                           (AND (EQ TYPE 'VARS)
                                (DELFROMCOM1 COM NAME T)))
                      (AND (EQ TYPE (CAR COM))
                           (DELFROMCOM1 COM NAME])

(DELFROMCOM1
  [LAMBDA (COM NAME FLG)                                 (* rmk%: "10-JUN-82 22:44")

    (* ;; 
  "FLG is passed on to REMOVEITEM, determines whether lists whose CAR is NAME will be removed")

    (LET (TEM VAL)
         (COND
            ((EQ (CADR COM)
                 '*)
             (COND
                ([AND (LITATOM (SETQ TEM (CADDR COM)))
                      (NEQ (SETQ VAL (GETTOPVAL TEM))
                           (SETQ VAL (REMOVEITEM NAME VAL FLG]
                 (SAVESET TEM VAL T 'NOPRINT)
                 T)))
            ((NEQ (CDR COM)
                  (SETQ TEM (REMOVEITEM NAME (CDR COM)
                                   FLG)))
             (/RPLACD COM TEM)
             (MARKASCHANGED COMSNAME 'VARS)
             T])

(REMOVEITEM
  [LAMBDA (X LST FLG)                                    (* ; "Edited 25-May-88 17:52 by drc:")
                                                             (* lmm "10-FEB-78 17:29")

    (* ;; 
  "returns a subset of LST with X deleted;  if FLG is set, also remove elements whose CAR is X")

    (COND
       [[OR (MEMBER X LST)
            (AND FLG (SOME LST (FUNCTION (LAMBDA (Y)
                                           (EQUAL (CAR (LISTP Y))
                                                  X]
        (SUBSET LST (FUNCTION (LAMBDA (Y)
                                (AND (NOT (EQUAL Y X))
                                     (OR (NOT FLG)
                                         (NLISTP Y)
                                         (NOT (EQUAL (CAR Y)
                                                     X]
       (T LST])

(MOVETOFILE
  [LAMBDA (TOFILE NAME TYPE FROMFILE)                    (* rmk%: "18-OCT-79 19:51")
                                                             (* ; "To move items between files")
    (SETQ TYPE (GETFILEPKGTYPE TYPE))
    [COND
       ((OR (EQ TYPE 'FNS)
            FROMFILE)                                        (* ; 
       "FNS definition can reside on file if LOADFNS was done.  This guarantees that it is loaded.")
        (PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE '(NOCOPY NODWIM]
    (AND (EQ TYPE 'FNS)
         (MARKASCHANGED NAME TYPE))                      (* ; 
                                                   "FNS won't get dumped unless they are `changed'")
    (DELFROMFILES NAME TYPE FROMFILE)
    (ADDTOFILE NAME TYPE TOFILE])
)

(MOVD? 'DELFROMFILES 'DELFROMFILE NIL T)

(MOVD? 'MOVETOFILE 'MOVEITEM NIL T)

(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)



(* ; "functions for doing things and marking them changed and auxiliary functions")

(DEFINEQ

(SAVEPUT
  [LAMBDA (ATM PROP VAL)                                 (* lmm " 7-May-84 16:56")

    (* ;; "analogous to SAVESET but also marks changed property lists;  LISPXFNS are marked to change PUT and PUTPROP to SAVEPUT")

    [COND
       ((NOT (LITATOM ATM))
        (ERRORX (LIST 14 ATM]
    (PROG ((X (GETPROPLIST ATM))
           X0 TEM OLDFLG)
      LOOP
          (COND
             ((NLISTP X)
              (COND
                 ((AND (NULL X)
                       X0)                                   (* ; 
                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")
                  (SETQ TEM (LIST PROP VAL))
                  (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                        LISPXHIST))
                  (FRPLACD (CDR X0)
                         TEM)
                  (GO RET)))

              (* ;; "property list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add new property at beginning")

              )
             ((NLISTP (CDR X))

              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning.")

              )
             [(EQ (CAR X)
                  PROP)
              (SETQ OLDFLG (NEQ (EQUALN (CADR X)
                                       VAL 400)
                                T))                          (* ; "i.e. it probably changed")
              (/RPLACA (CDR X)
                     VAL)
              (COND
                 ((NOT OLDFLG)
                  (GO RET1))
                 (T (OR (EQ DFNFLG T)
                        (LISPXPRINT (LIST 'new PROP 'property 'for ATM)
                               T T))
                    (GO RET]
             (T (SETQ X (CDDR (SETQ X0 X)))
                (GO LOOP)))
          [SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM]
          (SETPROPLIST ATM TEM)
          (AND LISPXHIST (UNDOSAVE (LIST '/PUT-1 ATM TEM)
                                LISPXHIST))
      RET (MARKASCHANGED (LIST ATM PROP)
                 'PROPS
                 (NOT OLDFLG))
      RET1
          (AND ADDSPELLFLG (ADDSPELL ATM 0))
          (RETURN VAL])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(OR (CHANGENAME 'PUTPROPS 'PUTPROP 'SAVEPUT)
    (CHANGENAME 'PUTPROPS '/PUT 'SAVEPUT))
)
(DEFINEQ

(UNMARKASCHANGED
  [LAMBDA (NAME TYPE)                                    (* JonL "24-Jul-84 19:59")

    (* ;; "says to remove NAME from TYPE's changedlst, and also to remove it from any FILE properties.  Value is name if anything is done")

    (PROG (ANYFLG)
          (bind TAIL [CHANGED _ (fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE
                                                                          TYPE
                                                                          'TYPE]
             while (SETQ TAIL (MEMBER NAME CHANGED)) do (/RPLACA TAIL)
                                                               (SETQ ANYFLG T))
          [for F TAIL PROP TYPEDPROP in FILELST
             when [SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP
                                                    (ASSOC TYPE (fetch TOBEDUMPED
                                                                   of (SETQ PROP
                                                                           (fetch FILEPROP
                                                                              of F]
             do (SETQ ANYFLG T)
                   (COND
                      ((SETQ TAIL (REMOVE (CAR TAIL)
                                         (CDR TYPEDPROP)))
                       (/RPLACD TYPEDPROP TAIL))
                      (T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP
                                                                              (fetch TOBEDUMPED
                                                                                 of PROP]
          (RETURN (AND ANYFLG NAME])

(PREEDITFN
  [LAMBDA (ATM TYPE EDITCHANGES)                         (* rmk%: "18-FEB-82 21:49")
                                                             (* ; 
                                           "EDITL is advised to call this before editing something")
    (AND FILEPKGFLG (SELECTQ TYPE
                        (PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                   (CONS))
                                                            CLISPARRAY))
                                      (for X in (GETPROPLIST ATM)
                                         do (OR (NLISTP X)
                                                    (GETHASH X CLISPARRAY)
                                                    (PUTHASH X (CONS (CAR X)
                                                                     (CDR X))
                                                           CLISPARRAY]

                                 (* ;; "note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any destructive edit is made")

                                 [RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS)
                                                      EDITCHANGES
                                                      (APPEND (GETPROPLIST ATM])
                        (VARS [COND
                                 ((EQMEMB 'ALIST (GETPROP ATM 'VARTYPE))
                                  [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
                                                                    (CONS))
                                                             CLISPARRAY))
                                       (for X in (EVALV ATM)
                                          do (OR (NLISTP X)
                                                     (GETHASH X CLISPARRAY)
                                                     (PUTHASH X (CONS (CAR X)
                                                                      (CDR X))
                                                            CLISPARRAY]
                                  (RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS)
                                                       EDITCHANGES
                                                       (for X in (EVALV ATM)
                                                          collect (CAR X])
                        NIL])

(POSTEDITPROPS
  [LAMBDA (EDITCHANGES OLDPROPS)                         (* rmk%: "18-FEB-82 21:50")
                                                             (* ; "was RESETSAVE'd from PREEDITFN")
    (PROG (OV FOUNDCHANGE)
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP)
                 when (for OLDPROP on OLDPROPS by (CDDR OLDPROP)
                             do (COND
                                       ((EQ (CAR OLDPROP)
                                            (CAR NEWPROP))   (* ; "Found the property")
                                        [AND (EQ (CADR OLDPROP)
                                                 (CADR NEWPROP))
                                             (COND
                                                ((NLISTP (CADR OLDPROP))
                                                             (* ; "value is same")
                                                 (RETURN))
                                                ((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP)
                                                                                 CLISPARRAY))
                                                      (EQ (CAADR NEWPROP)
                                                          (CAR OV))
                                                      (EQ (CDADR NEWPROP)
                                                          (CDR OV)))
                                                 (PUTHASH (CADR NEWPROP)
                                                        NIL CLISPARRAY)
                                                             (* ; 
                                         "value has been edited (CLISPARRAY translation went away)")
                                                 (RETURN]
                                        (RETURN T))) finally 
                                                             (* ; "didn't find the property")
                                                           (RETURN T))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 (CAR NEWPROP))
                               'PROPS NIL)
                       (SETQ FOUNDCHANGE T))
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])

(POSTEDITALISTS
  [LAMBDA (EDITCHANGES OLDTOKENS)                        (* rmk%: " 4-JAN-82 10:14")
    (PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES]
                                                             (* ; 
                                                           "called after an ALIST has been edited")
          (OR FILEPKGFLG (RETURN))
          (COND
             ((CADR EDITCHANGES)
              (for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES))
                 do (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                 X)
                               'ALISTS NIL)
                       (SETQ FOUNDCHANGE T))
              [for NEWENTRY in NEWENTRIES
                 do (COND
                           ([AND (LISTP NEWENTRY)
                                 (NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY CLISPARRAY))
                                           (EQ (CAR NEWENTRY)
                                               (CAR OV))
                                           (EQ (CDR NEWENTRY)
                                               (CDR OV]
                            (PUTHASH NEWENTRY NIL CLISPARRAY)
                            (MARKASCHANGED (LIST (CAR EDITCHANGES)
                                                     (CAR NEWENTRY))
                                   'ALISTS NIL)
                            (SETQ FOUNDCHANGE T]
              (AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
                                      NIL])
)

(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
                       (PUTPROP . SAVEPUT))



(* ; "sub-functions for file package commands & types")

(DEFINEQ

(ALISTS.GETDEF
  [LAMBDA (NAME TYPE OPTIONS)                            (* Pavel " 7-Oct-86 17:24")
    (AND (LISTP NAME)
         (CL:SYMBOLP (CAR NAME))
         (LET [(ASSOCIATION (ASSOC (CADR NAME)
                                   (GETTOPVAL (CAR NAME]
              (AND ASSOCIATION (LIST 'ADDTOVAR (CAR NAME)
                                     ASSOCIATION])

(ALISTS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm "16-OCT-78 20:02")
                                                             (* ; 
                                          "called by MARKASCHANGED when an ALIST entry has changed")
    (PROG [(VARTYPE (GETPROP (CAR NAME)
                           'VARTYPE]
          (AND (LISTP VARTYPE)
               (EQ (CAR VARTYPE)
                   'ALIST)
               (RETFROM 'MARKASCHANGED (MARKASCHANGED (CADR NAME)
                                              (CADR VARTYPE)
                                              NEWFLG])

(CLEARCLISPARRAY
  [LAMBDA (NAME TYPE REASON)
    (DECLARE (SPECVARS NAME TYPE REASON))            (* lmm "14-Aug-84 15:03")
    (AND CLISPARRAY (MAPHASH CLISPARRAY (COND
                                           [(EQ TYPE 'I.S.OPRS)
                                            (FUNCTION (LAMBDA (TRAN FORM)
                                                        (AND (MEMB NAME FORM)
                                                             (PUTHASH FORM NIL CLISPARRAY]
                                           (T                (* ; "MACRO changed")
                                              (FUNCTION (LAMBDA (TRAN FORM)
                                                          (COND
                                                             ((OR (EQ NAME (CAR FORM))
                                                                  (EQ (CAR (GETPROP (CAR FORM)
                                                                                  'CLISPWORD))
                                                                      'CHANGETRAN))
                                                              (PUTHASH FORM NIL CLISPARRAY])

(EXPRESSIONS.WHENCHANGED
  [LAMBDA (EXPR)                                         (* ; "Edited  6-Apr-87 20:21 by Pavel")
    (SELECTQ (CAR EXPR)
        ((SETQ SETQQ) 
             (UNMARKASCHANGED (CADR EXPR)
                    'VARS))
        ((PROGN PROG) 
             (for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X)))
        NIL])

(MAKEALISTCOMS
  [NLAMBDA X                                             (* rmk%: "14-OCT-83 13:34")

    (* ;; "make command to dump prettydefmacros")

    (LIST
     (CONS 'ADDVARS
           (for PR in X
              join (for ALISTNAME inside (CAR PR)
                          collect (CONS ALISTNAME
                                            (for ATNAME inside (CDR PR) bind ENTRY
                                               when (SETQ ENTRY
                                                         (OR (SASSOC ATNAME (GETTOPVAL ALISTNAME))
                                                             (PROGN (LISPXPRINT (LIST 'no ATNAME
                                                                                      'entry
                                                                                      'on ALISTNAME)
                                                                           T T)
                                                                    NIL))) collect ENTRY])

(MAKEFILESCOMS
  [NLAMBDA FILES                                         (* JonL "12-FEB-83 19:02")

    (* ;; "This scans the command just to warn the user about any errors.  Must match up with the big SELECTQ in FILESLOAD NIL")

    [for FILE in FILES
       do
       (OR
        (LITATOM FILE)
        (while (LISTP FILE)
           do (SELECTQ (CAR (OR (LISTP FILE)
                                    (RETURN)))
                      ((LOADCOMP LOADFROM))
                      (FROM (pop FILE)
                            (if (OR (EQ (CAR FILE)
                                            'VALUEOF)
                                        (if (AND (EQ (CAR FILE)
                                                         'VALUE)
                                                     (EQ (CADR FILE)
                                                         'OF))
                                            then (pop FILE)))
                                then (pop FILE)))
                      ((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR))
                      (OR (FMEMB (CAR FILE)
                                 LOADOPTIONS)
                          (PRINT (CONS (CAR FILE)
                                       '(-- unrecognized FILES option))
                                 T)))
                 (pop FILE]
    (CONS 'FILESLOAD FILES])

(MAKELISPXMACROSCOMS
  [NLAMBDA X                                             (* lmm " 5-SEP-78 23:15")
    (PROG (TEM TEM2)
          (RETURN (CONS [CONS 'ALISTS (SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                   LISPXHISTORYMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXHISTORYMACROS TEM)))
                                                       (AND [SETQ TEM (SUBSET X
                                                                             (FUNCTION (LAMBDA (Z)
                                                                                         (FASSOC
                                                                                          Z 
                                                                                          LISPXMACROS
                                                                                          ]
                                                            (LIST (CONS 'LISPXMACROS TEM]
                        (SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z LISPXCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'LISPXCOMS TEM2]
                                          (AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
                                                                                (FMEMB Z HISTORYCOMS]
                                               (LIST (LIST 'ADDVARS (CONS 'HISTORYCOMS TEM2])

(MAKEPROPSCOMS
  [NLAMBDA X                                             (* lmm "26-FEB-78 17:10")

    (* ;; "make command to dump PROPS")

    (for PAIR in X collect (CONS 'PROP (CONS (COND
                                                            ((AND (LISTP (CDR PAIR))
                                                                  (NULL (CDDR PAIR)))
                                                             (CADR PAIR))
                                                            (T (CDR PAIR)))
                                                         (OR (LISTP (CAR PAIR))
                                                             (LIST (CAR PAIR])

(MAKEUSERMACROSCOMS
  [NLAMBDA X                                             (* rmk%: " 3-JAN-82 23:20")
    (PROG (TEM)
          [COND
             [X (for Y in X
                   do (OR (FASSOC Y USERMACROS)
                              (FASSOC Y EDITMACROS)
                              (LISPXPRINT (CONS Y '(-- no entry on USERMACROS))
                                     T T]
             (T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS 'CAR))
                               X]
          (RETURN (LIST (CONS 'ADDVARS
                              (NCONC (for VAR in '(USERMACROS EDITMACROS)
                                        when (SETQ TEM (for Y in (GETTOPVAL VAR)
                                                              when (FMEMB (CAR Y)
                                                                              X) collect Y))
                                        collect (CONS VAR TEM))
                                     (for LST in '(EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS 
                                                                 DONTSAVEHISTORYCOMS)
                                        when [SETQ TEM
                                                  (SUBSET (GETTOPVAL LST)
                                                         (FUNCTION (LAMBDA (Y)
                                                                     (OR (FMEMB Y X)
                                                                         (AND (LISTP Y)
                                                                              (FMEMB (CAR Y)
                                                                                     X]
                                        collect (CONS LST TEM])

(PROPS.WHENCHANGED
  [LAMBDA (NAME TYPE NEWFLG)                             (* lmm " 7-SEP-78 22:08")
    (PROG [(PROPTYPE (GETPROP (CADR NAME)
                            'PROPTYPE]
          (COND
             [PROPTYPE (RETFROM 'MARKASCHANGED (COND
                                                  ((NEQ PROPTYPE 'IGNORE)
                                                   (MARKASCHANGED (CAR NAME)
                                                          PROPTYPE NEWFLG]
             (T (SELECTQ (CADR NAME)
                    (CLISPWORD (CLEARCLISPARRAY (CAR NAME)))
                    NIL])

(FILEGETDEF.LISPXMACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:12")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (EQ FIRST 'ADDTOVAR)
                                                                   (MEMB SECOND '(LISPXMACROS 
                                                                                        LISPXCOMS))
                                                                   T]
                when (SELECTQ (CADR X)
                             (LISPXMACROS                    (* ; 
                      "Rebuild the expressions cause there might be other elements in the ADDTOVAR")
                                          (AND (SETQ X (ASSOC NAME (CDDR X)))
                                               (SETQ X (LIST 'ADDTOVAR 'LISPXMACROS X))))
                             (LISPXCOMS [COND
                                           ((MEMB NAME (CDDR X))
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS NAME)))
                                           ((SETQ X (ASSOC NAME (CDDR X)))
                                                             (* ; "For synonym pairs")
                                            (SETQ X (LIST 'ADDTOVAR 'LISPXCOMS X])
                             NIL) collect X])

(FILEGETDEF.ALISTS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'ADDTOVAR)
                                                          (EQ SECOND (CAR NAME]
       when (SETQ X (ASSOC (CADR NAME)
                               (CDDR X))) collect X
       finally (RETURN (COND
                              ($$VAL (CONS 'ADDTOVAR (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.RECORDS
  [LAMBDA (NAME TYPE SOURCE OPTIONS NOTFOUND)            (* lmm "26-Jun-86 15:56")
    (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                              (AND (MEMB FIRST CLISPRECORDTYPES)
                                                   (OR (EQ SECOND NAME)
                                                       (AND (MEMB SECOND '(%( %[))
                                                            (PROGN (RATOM)
                                                                   (RATOM)
                                                                   (RATOM)
                                                                   (EQ NAME (RATOM]
         (if (EQ (CAAR VAL)
                     'NOT-FOUND%:)
             then NOTFOUND
           elseif (CDR VAL)
             then (CONS 'PROGN VAL)
           else (CAR VAL])

(FILEGETDEF.PROPS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:13")
    (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                     (AND (EQ FIRST 'PUTPROPS)
                                                          (EQ SECOND (CAR NAME]
       join (for TAIL on (CDDR X) by (CDDR TAIL) when (EQ (CAR TAIL)
                                                                              (CADR NAME))
                   join (LIST (CAR TAIL)
                                  (CADR TAIL)))
       finally (RETURN (COND
                              ($$VAL (CONS 'PUTPROPS (CONS (CAR NAME)
                                                           $$VAL])

(FILEGETDEF.MACROS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "28-May-86 09:51")
    (MKPROGN (for X in [LOADFNS NIL SOURCE 'GETDEF '(LAMBDA (FIRST SECOND)
                                                              (AND (FMEMB FIRST '(PUTPROPS DEFMACRO))
                                                                   (EQ SECOND NAME]
                join (if (EQ (CAR X)
                                     'DEFMACRO)
                             then (LIST X)
                           else (for TAIL on (CDDR X) by (CDDR TAIL)
                                       when (FMEMB (CAR TAIL)
                                                       MACROPROPS) collect (LIST 'PUTPROPS
                                                                                     (CADR X)
                                                                                     (CAR TAIL)
                                                                                     (CADR TAIL])

(FILEGETDEF.VARS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm " 4-Jul-85 15:14")
    (for X in (LOADFNS NIL SOURCE 'GETDEF NAME)
       do (SELECTQ (CAR X)
                  ((RPAQQ SETQQ) 
                       (RETURN (CADDR X)))
                  ((RPAQ SETQ RPAQ?) 
                       (RETURN (EVAL (CADDR X))))
                  NIL) finally (RETURN 'NOBIND])

(FILEGETDEF.FNS
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: "29-Aug-86 22:30")
    (LET (MAP ENV)
         (COND
            [(AND (EQMEMB 'FAST OPTIONS)
                  (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP)
                                (GET-ENVIRONMENT-AND-FILEMAP SOURCE))
                         MAP))
             (for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME
                                                                                      (CDDR PAIR]
                do [OR (OPENP SOURCE)
                           (RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT
                                                                             'OLD]
                      (SETFILEPTR SOURCE MAPLOC)
                      (RETURN (WITH-READER-ENVIRONMENT ENV
                                  [COND
                                     ((EQMEMB 'ARGLIST OPTIONS)
                                      (RATOM SOURCE)
                                      (READ SOURCE)
                                      (RATOM SOURCE)
                                      (LIST (READ SOURCE)
                                            (READ SOURCE)))
                                     (T (CADR (READ SOURCE])]
            (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE])

(FILEPKGCOMS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 11:29")
    (PROG (COM TYP)
          [SELECTQ (CAR (LISTP DEFINITION))
              (COM (SETQ COM (CDR DEFINITION)))
              (TYPE (SETQ TYP (CDR DEFINITION)))
              (PROGN (SETQ COM (CDR (ASSOC 'COM DEFINITION)))
                     (SETQ TYP (CDR (ASSOC 'TYPE DEFINITION]

     (* ;; "Check properties first, so that we don't smash some and then get an error in a later call to FILEPKGCOM/TYPE")

          (for I in COM by (CDDR I) do (SELECTQ I
                                                           ((ADD DELETE MACRO CONTENTS CONTAIN COM))
                                                           (ERROR I 
                                                                  "not file package command property"
                                                                  )))
                                                             (* ; 
                                                   "COM merely adds to spelling list, for builtins")
          [FILEPKGCOM NAME 'CONTENTS (OR (LISTGET COM 'CONTENTS)
                                             (LISTGET COM 'CONTAIN]
                                                             (* ; "Until CONTAIN is de-documented.")
          (for PROP in '(ADD DELETE MACRO COM) do (FILEPKGCOM NAME PROP
                                                                         (LISTGET COM PROP)))
          [for I in TYP by (CDDR I) do (OR (FMEMB I FILEPKGTYPEPROPS)
                                                           (SELECTQ I
                                                               ((DESCRIPTION TYPE))
                                                               (ERROR I 
                                                             "not file package type/command property"
                                                                      ]
                                                             (* ; 
                                                  "TYPE merely adds to spelling list, for builtins")
          (for PROP in (UNION '(DESCRIPTION TYPE)
                                      FILEPKGTYPEPROPS) do (FILEPKGTYPE NAME PROP
                                                                      (LISTGET TYP PROP])

(FILES.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "15-Jul-85 17:13")
    (PROGN (PUTDEF (FILECOMS NAME)
                  'VARS
                  (CAR DEFINITION)
                  REASON)                                    (* ; "DEFINE THE COMS")
           (ADDFILE NAME)                                (* ; 
                                                           "MAKE SURE IT IS A FILE PACKAGE ENTITY")
           [/replace TOBEDUMPED of (fetch FILEPROP of NAME)
                                          (FILEPKG.MERGECHANGES (CADR DEFINITION)
                                                 (fetch TOBEDUMPED of (fetch FILEPROP
                                                                                 of NAME]
           (OR (fetch FILEDATES of NAME)
               (/replace FILEDATES of NAME with (CADDR DEFINITION])

(VARS.PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* lmm "29-Jul-85 20:59")
    (/SETTOPVAL NAME DEFINITION T])

(FILES.WHENCHANGED
  [LAMBDA (NAME TYPE REASON)
    (MARKASCHANGED (FILECOMS NAME)
           'VARS REASON])
)

(ADDTOVAR MACROPROPS MACRO BYTEMACRO DMACRO)

(ADDTOVAR SYSPROPS PROPTYPE)

(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)

(PUTPROPS SUBR PROPTYPE IGNORE)

(PUTPROPS LIST PROPTYPE IGNORE)

(PUTPROPS CODE PROPTYPE IGNORE)

(PUTPROPS FILEDATES PROPTYPE IGNORE)

(PUTPROPS FILE PROPTYPE IGNORE)

(PUTPROPS FILEMAP PROPTYPE IGNORE)

(PUTPROPS EXPR PROPTYPE FNS)

(PUTPROPS VALUE PROPTYPE VARS)

(PUTPROPS COPYRIGHT PROPTYPE FILES)

(PUTPROPS FILETYPE PROPTYPE FILES)

(PUTPROPS BAKTRACELST VARTYPE ALIST)

(PUTPROPS BREAKMACROS VARTYPE ALIST)

(PUTPROPS COMPILETYPELST VARTYPE ALIST)

(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))

(PUTPROPS ERRORTYPELST VARTYPE ALIST)

(PUTPROPS FONTDEFS VARTYPE ALIST)

(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))

(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))

(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)

(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)

(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)

(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))



(* ; "Define the commands below AFTER the various properties have been established.")


(ADDTOVAR USERMACROS
          (M NIL (MAKE FILE FILE))
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITMACROS
          (M (X . Y)
             (E (MARKASCHANGED (COND ((LISTP 'X)
                                      (CAR 'X))
                                     (T 'X))
                       'USERMACROS)
                T)
             (ORIGINAL (M X . Y))))

(ADDTOVAR EDITCOMSA M)

(ADDTOVAR EDITCOMSL M)



(* ; "GETDEF methods")

(DEFINEQ

(RENAME
  [LAMBDA (OLD NEW TYPES FILES METHOD)               (* JonL "24-Jul-84 20:01")
    (PROG ((TYPES (GETFILEPKGTYPE TYPES 'TYPE NIL OLD)))

     (* ;; "special kludge: change the callers BEFORE if we are changing a field;  this is so the CHANGECALLERS won't get an UNABLE TO DWIMIFY message")

          [for TYPE inside TYPES when (NEQ TYPE 'FIELDS)
             do (COPYDEF OLD NEW TYPE NIL (COND
                                                     ((EQ TYPE 'VARS)
                                                      'NOERROR]
          (CHANGECALLERS OLD NEW TYPES FILES METHOD)
          [for TYPE inside TYPES do (COND
                                                   ((AND (EQ TYPE 'FIELDS)
                                                         (HASDEF OLD 'FIELDS))

                                 (* ;; "The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it found a record with the field on a file.  Otherwise, COPYDEF essentially will just do the necessary substitution in the existing record declarations, given that definitions for FIELDS are mutually exclusive.")

                                                    (COPYDEF OLD NEW 'FIELDS))
                                                   (T (DELDEF OLD TYPE]
          (RETURN NEW])

(CHANGECALLERS
  [LAMBDA (OLD NEW AS-TYPES FILES METHOD)            (* ; "Edited  6-Dec-86 01:25 by lmm")
    (PROG ((AS-TYPES (GETFILEPKGTYPE AS-TYPES))
           REL TEM EDITCOMS FNS)
          (OR METHOD (SETQ METHOD DEFAULTRENAMEMETHOD))
          [SETQ EDITCOMS
           (LIST (COND
                    [(OR (EQMEMB 'CAREFUL METHOD)
                         (PROGN (SETQ TEM (TYPESOF OLD NIL AS-TYPES))
                                (printout T "Warning --" OLD " is also defined as " TEM T)))

                     (* ;; "This creates a `command' that searches like EXAM, but interrogates the user about whether to do the Rename.  Y means do it, No means skip, anything else goes into TTY.")

                     (SUBPAIR '(OLD NEW)
                            (LIST OLD NEW)
                            '(BIND (LPQ (F OLD N)
                                            (MARK %#1)
                                            (ORR (1 !0 P)
                                                 NIL)
                                            (MARK %#2)
                                            (COMS (SELECTQ (ASKUSER NIL NIL "   Replace ? "
                                                                  '((Y "Yes
")
                                                                    (N "No
")
                                                                    (%
 "")
                                                                    (%  "")
                                                                    (%
 "")
                                                                    (& ""))
                                                                  NIL NIL '(NOECHOFLG T))
                                                      (Y '(R1 OLD NEW))
                                                      (N NIL)
                                                      'TTY%:))
                                            (MARK %#3)
                                            (IF (EQ (%## (\ %#3))
                                                        (%## (\ %#2)))
                                                   ((\ %#1))
                                                   NIL]
                    (T (LIST 'R OLD NEW]
          (SELECTQ (COND
                      ((AND (EQMEMB 'MASTERSCOPE METHOD)
                            MSDATABASELST
                            (for TYPE inside AS-TYPES
                               do [COND
                                         ((SETQ TEM (SELECTQ TYPE
                                                        ((FNS FUNCTIONS SPECIAL-FORMS OPTIMIZERS) 
                                                             'CALL)
                                                        (MACROS '(CALL DIRECTLY))
                                                        ((VARS VARIABLES) 
                                                             '(USE OR BIND))
                                                        ((RECORDS FIELDS I.S.OPRS) 
                                                             (LIST 'USE 'AS TYPE))
                                                        (RETURN NIL)))
                                          (COND
                                             (REL (SETQ REL (LIST TEM 'OR REL)))
                                             (T (SETQ REL TEM] FINALLY (RETURN REL)))

                       (* ;; "can only use masterscope if (a) we say to, (b) something's been analyzed, and (c) the types the function is are known")

                       'MASTERSCOPE)
                      ((EQMEMB 'EDITCALLERS METHOD)
                       'EDITCALLERS)
                      (T 'SEARCH))
              (MASTERSCOPE (MAPC [SETQ FNS (NCONC [COND
                                                     ((NULL FILES)
                                                      (UPDATEFILES)
                                                      (FILEPKGCHANGES 'FNS]
                                                  (for FILE inside (OR FILES FILELST)
                                                     join (FILEFNSLST FILE]
                                 (FUNCTION UPDATEFN))
                           (SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL (PARSERELATION REL))
                                                          T)
                                            FNS)))
              (EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST)
                                          when (SETQ TEM (EDITCALLERS OLD X T))
                                          collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM)))
                                                             X))))
              (SEARCH (SETQ FNS (for X inside (OR FILES FILELST) join (FILEFNSLST
                                                                                   X))))
              (ERROR "UNRECOGNIZED RENAME METHOD" METHOD))
          (AND (EQMEMB 'FNS AS-TYPES)
               (FMEMB OLD FNS)
               (SETQ FNS (REMOVE OLD FNS)))
          (EDITFROMFILE FNS FILES OLD EDITCOMS)
          [for TYPE inside AS-TYPES
             do (for FILE in (WHEREIS OLD TYPE FILES)
                       do (AND (ADDTOFILE NEW TYPE FILE)
                                   (DELFROMFILES OLD TYPE FILE)
                                   (printout T OLD " changed to " NEW " on " FILE)))
                   (COND
                      ((SETQ TEM (WHEREIS OLD TYPE FILES))
                       (printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM]
          (COND
             (REL (UPDATECHANGED)
                  (COND
                     ((AND (SETQ TEM (GETRELATION OLD REL T))
                           (WHEREIS TEM 'FNS FILES))
                      (printout T "Couldn't find where " OLD " is referenced in " TEM T])
)
(DEFINEQ

(SHOWDEF
  [LAMBDA (NAME TYPE FILE)                              (* ; "Edited 16-Apr-2018 21:35 by rmk:")
                                                             (* ; 
                                                 "prettyprint NAME as it would be dumped as a TYPE")
    (RESETLST
        (PROG (ORIGFLG FNSLST FL PRETTYCOMSLST NEWFILEMAP)
              (DECLARE (SPECVARS . T))
              [AND FILE (NEQ FILE (OUTPUT))
                   (if (SETQ FL (OPENP FILE 'OUTPUT))
                       then (RESETSAVE (OUTPUT FL))
                     else (OUTFILE FILE)
                           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                                (OUTPUT]
              (PRETTYCOM (MAKENEWCOM NAME TYPE))))])

(COPYDEF
  [LAMBDA (OLD NEW TYPE SOURCE OPTIONS)              (* lmm "14-Aug-84 18:38")
                                                             (* ; "like MOVD, but takes a type.")
    (PROG (TEM DEF)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          [SETQ DEF (GETDEF OLD TYPE SOURCE (COND
                                                   ((EQ OPTIONS 'NOCOPY)
                                                    NIL)
                                                   (T (REMOVE 'NOCOPY (MKLIST OPTIONS]
                                                             (* ; 
      "The default is for GETDEF to return a COPY.  Make sure that NOCOPY isn't in options though.")
          (SELECTQ TYPE
              (VARS)
              (FILES [for X in (CAR DEF)
                        do                               (* ; 
                                          "change all the listnames which are of form filenameTYPE")
                              (SELECTQ (CAR X)
                                  ((PROP IFPROP) 
                                       (SETQ X (CDR X)))
                                  NIL)
                              (COND
                                 ((EQ (CADR X)
                                      '*)
                                  (SETQ X (CDDR X))
                                  (COND
                                     ((AND (LITATOM (CAR X))
                                           (SETQ TEM (STRPOS OLD (CAR X)
                                                            1 NIL T T)))
                                      (SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X)
                                                                           TEM -1)))
                                             (COPY (GETTOPVAL (CAR X)))
                                             T)
                                      (FRPLACA X TEM])
              ((PROPS ALISTS) 
                   (OR (EQ (CAR NEW)
                           (CAR OLD))
                       (DSUBST (CAR NEW)
                              (CAR OLD)
                              DEF))
                   (OR (EQ (CADR NEW)
                           (CADR OLD))
                       (DSUBST (CADR NEW)
                              (CADR OLD)
                              DEF)))
              (DSUBST NEW OLD DEF))
          (PUTDEF NEW TYPE DEF)
          (RETURN NEW])

(GETDEF
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* lmm "13-Jul-85 04:10")

    (* ;; "returns the definition of NAME as a TYPE from SOURCE;  cause ERROR if not found unless OPTIONS is NOERROR --- usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy --- FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 --- If options is or contains a string, returns that string instead of causing error if no def found.  The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.")

    (PROG (DEF TEM (NOCOPY (EQMEMB 'NOCOPY OPTIONS)))
          (DECLARE (SPECVARS NOCOPY))
          (SELECTQ OPTIONS
              (0 (SETQQ OPTIONS (NOERROR NODWIM))
                 (SETQ NOCOPY T))
              (1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST))
                 (SETQ NOCOPY T))
              (T (SETQQ OPTIONS SPELL))
              NIL)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
          (SELECTQ SOURCE
              (0 (SETQQ SOURCE CURRENT))
              (T (SETQQ SOURCE SAVED))
              (NIL (SETQQ SOURCE ?))
              NIL)
          [SELECTQ SOURCE
              (CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS)))
              (? [LET [(NOERROR (CONS 'NOERROR (MKLIST OPTIONS]
                      (OR (NEQ (SETQ DEF (GETDEFCURRENT NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (NEQ (SETQ DEF (GETDEFSAVED NAME TYPE NOERROR))
                               (fetch NULLDEF of TYPE))
                          (SETQ DEF (GETDEFFROMFILE NAME TYPE 'FILE OPTIONS])
              (SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS)))
              (COND
                 ((AND (LISTP SOURCE)
                       (EQ (CAR SOURCE)
                           '=))
                  (SETQ DEF (CDR SOURCE)))
                 (T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS))
                    (SETQ NOCOPY T]
          (OR NOCOPY (SETQ DEF (COPY DEF)))
          (COND
             ((AND (EQ TYPE 'FNS)
                   (NOT (EQMEMB 'NODWIM OPTIONS)))
              (DWIMDEF DEF NAME SOURCE)))
          (RETURN DEF])

(GETDEFCOM
  [LAMBDA (X)                                            (* lmm " 4-Jul-85 13:31")

    (* ;; "In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file package to print it out to a file and then reading the file back in.  Actually, though, that is a two stage process where the `command' to print out the datum is first macro expanded and then executed.  --- In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.  That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those commands (or NIL if it is `too hard' to figure out.) --- A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.")
                                                             (* ; "a RETFROM point")
    (for Y in X join (GETDEFCOM0 Y])

(GETDEFCOM0
  [LAMBDA (COM)                                          (* wt%: " 7-FEB-79 23:28")
    (PROG (TEM)
          (RETURN (COND
                     ((SETQ TEM (fetch MACRO of (CAR COM)))
                                                             (* COND ((fetch CONTENTS of
                                                           (CAR COM)) (* ; 
                        "if it has a CONTENTS function, generally means it is not safe to evaluate")
                                                           (RETFROM (QUOTE GETDEFCOM))))
                      (for Y in (SUBPAIR (CAR TEM)
                                               (PRETTYCOM1 COM)
                                               (CDR TEM)) join (GETDEFCOM0 Y)))
                     (T (SELECTQ (CAR COM)
                            (COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X)))
                            (ADDVARS (for Y in (PRETTYCOM1 COM)
                                        collect (CONS 'ADDTOVAR Y)))
                            (APPENDVARS (for Y in (PRETTYCOM1 COM)
                                           collect (CONS 'APPENDTOVAR Y)))
                            (P (APPEND (PRETTYCOM1 COM)))
                            (RETFROM 'GETDEFCOM])

(GETDEFCURRENT
  [LAMBDA (NAME TYPE OPTIONS)                            (* ; "Edited  2-May-87 19:00 by Pavel")
                                                             (* ; 
                                                           "Gets the current definition--source=0")
    (LET
     (DEF)
     (COND
        ((AND (SETQ DEF (fetch GETDEF of TYPE))
              (NEQ DEF T))

         (* ;; "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")

         (OR (NEQ (SETQ DEF (APPLY* DEF NAME TYPE OPTIONS))
                  (fetch NULLDEF of TYPE))
             (GETDEFERR NAME TYPE OPTIONS))
         DEF)
        (T
         (OR
          (NEQ
           [SETQ DEF
            (SELECTQ TYPE
                (FNS (AND (LITATOM NAME)
                          (EXPRP (SETQ DEF (VIRGINFN NAME)))
                          DEF))
                (VARS (if (LITATOM NAME)
                          then (GETTOPVAL NAME)
                        else 'NOBIND))
                ((FIELDS RECORDS) 
                     (if (LITATOM NAME)
                         then [SETQ DEF (SELECTQ TYPE
                                                (RECORDS (RECLOOK NAME))
                                                (MKPROGN (FIELDLOOK NAME]
                               (if (EQMEMB 'EDIT OPTIONS)
                                   then (COPY DEF)
                                 else DEF)))
                (FILES                                       (* ; 
              "what is the `definition' of a file?  -- I guess the COMS which say what it contains")
                       [if (LITATOM NAME)
                           then (if (SETQ DEF (GETFILEDEF NAME))
                                        then (UPDATEFILES)
                                              (LIST (LISTP (GETTOPVAL (FILECOMS DEF)))
                                                    (fetch TOBEDUMPED
                                                       of (fetch FILEPROP of DEF))
                                                    (LISTP (fetch FILEDATES of DEF])
                (TEMPLATES (if (AND (LITATOM NAME)
                                        (SETQ DEF (GETTEMPLATE NAME)))
                               then (LIST 'SETTEMPLATE (KWOTE NAME)
                                              (KWOTE DEF))))
                (MACROS [if [AND (LITATOM NAME)
                                     (SETQ DEF (for X on (GETPROPLIST NAME)
                                                  by (CDDR X) when (FMEMB (CAR X)
                                                                                  MACROPROPS)
                                                  join (LIST (CAR X)
                                                                 (CADR X]
                            then `(PUTPROPS ,NAME ,@DEF])
                (EXPRESSIONS (LISTP NAME))
                (PROPS [AND (LISTP NAME)
                            (AND (SETQ DEF (SOME (GETPROPLIST (CAR NAME))
                                                 [FUNCTION (LAMBDA (X)
                                                             (EQ X (CADR NAME]
                                                 (FUNCTION CDDR)))
                                 (LIST 'PUTPROPS (CAR NAME)
                                       (CADR NAME)
                                       (CADR DEF])
                (FILEPKGCOMS [AND (LITATOM NAME)
                                  (PROG ((COM (FILEPKGCOM NAME))
                                         (TYP (FILEPKGTYPE NAME)))
                                        (RETURN (COND
                                                   ((AND COM TYP)
                                                    (LIST (CONS 'COM COM)
                                                          (CONS 'TYPE TYP)))
                                                   (COM (LIST (CONS 'COM COM)))
                                                   (TYP (LIST (CONS 'TYPE TYP])
                (FILEVARS (COND
                             ((AND (LITATOM NAME)
                                   (LISTP (SETQ DEF (GETTOPVAL NAME)))
                                   (WHEREIS NAME 'FILEVARS))
                              DEF)
                             (T 'NOBIND)))
                (LET
                 ((COMS (LIST (MAKENEWCOM NAME TYPE)))
                  FILE)
                 [COND
                    ((NOT (SETQ DEF (GETDEFCOM COMS)))
                     (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT*
                         (RESETLST
                             (RESETSAVE PRETTYFLG)
                             (RESETSAVE FONTCHANGEFLG)
                             [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH]
                             (PRETTYDEFCOMS COMS)
                             (SETFILEPTR FILE 0)
                             [SETQ DEF
                              (for X in (READFILE FILE)
                                 join
                                 (SELECTQ (CAR X)
                                     ((*) 
                                          NIL)
                                     (DECLARE%: (for Y on (CDR X)
                                                   unless (SELECTQ (CAR Y)
                                                                  ((COPYWHEN EVAL@LOADWHEN 
                                                                          EVAL@COMPILEWHEN) 
                                                                       (RETURN (LIST Y)))
                                                                  (FMEMB (CAR Y)
                                                                         DECLARETAGSLST))
                                                   collect (CAR Y)))
                                     (CL:EVAL-WHEN (CDDR X))
                                     (PROGN (CDR X))
                                     (LIST X]
                             (SETQ NOCOPY T)))]
                 (MKPROGN DEF]
           (fetch NULLDEF of TYPE))
          (GETDEFERR NAME TYPE OPTIONS))
         DEF])

(GETDEFERR
  [LAMBDA (NAME TYPE OPTIONS MSG)                        (* lmm "13-Jul-85 04:11")
    (DECLARE (USEDFREE NODEF))                           (* ; 
                                       "Message non-null if looking for saved or filed definition.")
    (PROG (TEM)
          (RETURN (COND
                     ((EQMEMB 'NOERROR OPTIONS)              (* ; 
                                               "We want to do the string search in the HASDEF case")
                      (RETURN (fetch NULLDEF of TYPE)))
                     [(AND (NULL MSG)
                           (EQMEMB 'SPELL OPTIONS)
                           (SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS)
                                                                          'SPELL)
                                                                   T)))
                           (NEQ TEM NAME))
                      (RETFROM 'GETDEF (GETDEF TEM TYPE '? (CONS 'NOERROR (MKLIST OPTIONS]
                     (T (for O inside OPTIONS when (STRINGP O)
                           do (RETFROM 'GETDEF O)
                           finally (ERROR NAME (CONS TYPE '(definition not found))
                                              T])

(GETDEFFROMFILE
  [LAMBDA (NAME TYPE SOURCE OPTIONS)                     (* bvm%: " 1-Oct-86 22:10")

    (* ;; "Tries to get definition from source file.  If successful, returns the definition.  Otherwise returns the NULLDEF of the type if OPTIONS contains NOERROR.")

    (DECLARE (SPECVARS NAME))
    (bind (NOTFOUND _ "not found")
           DEF SOURCE TEM2 for FILE inside (COND
                                                      ((EQ SOURCE 'FILE)
                                                       (WHEREIS NAME TYPE T))
                                                      (T SOURCE))
       when
       (AND
        (SETQ SOURCE (FINDFILE FILE T))
        (NEQ
         [SETQ DEF
          (COND
             ((SETQ TEM2 (fetch FILEGETDEF of TYPE))
              (APPLY* TEM2 NAME TYPE SOURCE OPTIONS NOTFOUND))
             (T
              (SELECTQ TYPE
                  (FNS (FILEGETDEF.FNS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  ((VARS FILEVARS) 
                       (FILEGETDEF.VARS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (MACROS (FILEGETDEF.MACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (PROPS (FILEGETDEF.PROPS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (RECORDS (FILEGETDEF.RECORDS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (ALISTS (FILEGETDEF.ALISTS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (LISPXMACROS (FILEGETDEF.LISPXMACROS NAME TYPE SOURCE OPTIONS NOTFOUND))
                  (COND
                     [(SETQ DEF (GET TYPE 'DEFINERS))
                      (LET [(VAL (LOADFNS NIL SOURCE 'GETDEF
                                        `(LAMBDA (FIRST SECOND)
                                           (AND (MEMB FIRST ',DEF)
                                                (OR (EQ SECOND NAME)
                                                    (AND (MEMB SECOND '(%( %[))
                                                         (PROGN (RATOM)
                                                                (RATOM)
                                                                (RATOM)
                                                                (EQ NAME (RATOM]
                                                             (* ; "ick!  Should use real closure")
                           (if (EQ (CAAR VAL)
                                       'NOT-FOUND)
                               then NOTFOUND
                             elseif (CDR VAL)
                               then (CONS 'PROGN VAL)
                             else (CAR VAL]
                     (T (RESETLST
                            (RESETSAVE (RESETUNDO))
                            [LET (LOAD-VERBOSE-STREAM)
                                 (DECLARE (SPECVARS LOAD-VERBOSE-STREAM))
                                                             (* ; 
                                                     "just in case we get a PRETTYCOMPRINT in here")
                                 (LOADFNS NIL SOURCE 'PROP (COND
                                                              ((LITATOM NAME)
                                                             (* ; 
                                         "If an atom, only bother with expressions that contain it")
                                                               (CONS (LIST '& '|..| NAME)))
                                                              (T T]
                            (GETDEFCURRENT NAME TYPE (CONS 'NOERROR (MKLIST OPTIONS))))]
         NOTFOUND)) do (AND (EQ SOURCE 'FILE)
                                (OR (FMEMB FILE FILELST)
                                    (CL:FORMAT T "(from ~A)~%%" SOURCE))) 
                                                             (* ; 
                                                        "Copying and dwimifying are done in GETDEF")
                          (RETURN DEF) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
                                                                  (APPEND '(no definition on)
                                                                         (MKLIST SOURCE])

(GETDEFSAVED
  [LAMBDA (NAME TYPE OPTIONS)                          (* ; "Edited 11-Aug-87 18:14 by cutting")
                                                             (* ; 
                                                           "Gets the `saved' definition--source=T")
    (SELECTQ TYPE
        (FNS (OR (GETPROP NAME 'EXPR)
                 (GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
        (VARS                                                (* ; 
                               "The value of a variable is never substituted into and never COPIED")
              (for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
                                                                                'VALUE)
                 do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS 
                                                                     "no saved value for "))))
        (OR (CDR (SASSOC NAME (FASSOC TYPE SAVEDDEFS)))
            (GETDEFERR NAME TYPE OPTIONS "no saved definition for "])

(PUTDEF
  [LAMBDA (NAME TYPE DEFINITION REASON)                  (* ; "Edited  8-Apr-87 12:52 by Pavel")
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (LET ((PUTDEF.METHOD (fetch PUTDEF of TYPE)))
         (COND
            (PUTDEF.METHOD (APPLY* PUTDEF.METHOD NAME TYPE DEFINITION REASON))
            (T (SELECTQ TYPE
                   (FNS (FNS.PUTDEF NAME TYPE DEFINITION REASON))
                   (VARS (VARS.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILES (FILES.PUTDEF NAME TYPE DEFINITION REASON))
                   (FILEPKGCOMS (FILEPKGCOMS.PUTDEF NAME TYPE DEFINITION REASON))
                   (EVAL DEFINITION))
               NAME])

(EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)
    (DECLARE (LOCALVARS . T)
           (SPECVARS SOURCE))                          (* ; "Edited 27-Jul-87 11:04 by cutting")

    (* ;; "lets you edit anything.  Given name and type, call editor on the definition (loading it in from SOURCE if necessary).  If you change it, then the definition gets unsaved.  OPTIONS is passed through from ED to the editor.")

    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (COND
       ((AND (fetch EDITDEF of TYPE)
             (APPLY* (fetch EDITDEF of TYPE)
                    NAME TYPE SOURCE EDITCOMS OPTIONS)))
       ((AND (EQ TYPE 'FNS)
             (NULL SOURCE))                                  (* ; 
                                "special hack for EDITDEF of FNS because of ability to EDITLOADFNS")
        (EDITDEF.FNS NAME EDITCOMS OPTIONS))
       (T (DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))
    NAME])

(DEFAULT.EDITDEF
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 11-Jun-92 16:26 by cat")
    (PROG [(DEF (COND
                   [SOURCE (GETDEF NAME TYPE SOURCE '(EDIT NOCOPY]
                   [(GETDEF NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR]
                   [(GETDEF NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR]
                   (T (LET ((FILES (WHEREIS NAME TYPE T)))
                           (CL:IF (NULL FILES)
                               (CL:FORMAT T "~S has no ~A definition.~%%" NAME TYPE)
                               [LET [(FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%%" NAME 
                                                         FILES)
                                                  (CL:IF (CL:ENDP (CDR FILES))
                                                      (CL:IF (CL:Y-OR-N-P 
                                                                    "Shall I load this file PROP? ")
                                                             (CAR FILES))
                                                      (ASKUSER NIL NIL 
                                                             "indicate which file to load PROP: "
                                                             (MAKEKEYLST FILES)
                                                             T))]
                                    (CL:WHEN FILE
                                        (LOAD FILE 'PROP)
                                        (GETDEF NAME TYPE '? '(EDIT NOCOPY)))])]

     (* ;; "the EDIT option says to return a COPY if editing this structure isn't enough, and some installation is necessary.")

          (DECLARE (SPECVARS RETRY))

     (* ;; "what is RETRY ???")

          (SETQ RETRY)
          (CL:WHEN DEF
              (EDITE DEF EDITCOMS NAME TYPE [FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
                                                             (* ; 
                                             "this function is called when there were changes made")
                                                        (FIXEDITDATE DEF)
                                                             (* ; "fix the edit date first - jtm")
                                                        (PUTDEF NAME TYPE DEF)
                                                        (MARKASCHANGED NAME TYPE 'CHANGED)

                                 (* ;; "woz 1/25/91 MARKASCHANGED must be called after PUTDEF, so sedit's markaschangedfn will see the new definition.  doc for PUTDEF says it calls MARKASCHANGED, but it doesn't always, so do it here.  this sometimes results in MARKASCHANGED getting called twice.")

                                                        ]
                     OPTIONS))])

(EDITDEF.FILES
  [LAMBDA (NAME TYPE SOURCE EDITCOMS OPTIONS)            (* ; "Edited 18-Mar-87 16:07 by woz")
    (EDITDEF (FILECOMS NAME)
           'VARS SOURCE EDITCOMS OPTIONS])

(LOADDEF
  [LAMBDA (NAME TYPE SOURCE)                             (* lmm "13-SEP-78 01:34")
    (PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE '(NODWIM NOCOPY])

(DWIMDEF
  [LAMBDA (DEF FN SOURCE)                                (* lmm " 6-Jun-86 17:23")
    (AND [OR (EQ DWIMIFYCOMPFLG T)
             (EQ CLISPIFYPRETTYFLG T)
             (EQ (CAR (CADDR DEF))
                 'CLISP%:)
             (SELECTQ SOURCE
                 ((CURRENT SAVED FILE ?) 
                      NIL)
                 (AND (LITATOM SOURCE)
                      (EQMEMB 'CLISP (GETPROP SOURCE 'FILETYPE]
         (LET ((NOSPELLFLG T)
               (DWIMESSGAG T)
               FILEPKGFLG LISPXHIST)
              (DECLARE (CL:SPECIAL NOSPELLFLG DWIMESSGAG FILEPKGFLG LISPXHIST))
              (DWIMIFY0 DEF (COND
                               ((OR (LISTP FN)
                                    (NULL FN))
                                '?)
                               (T FN))
                     NIL DEF])

(DELDEF
  [LAMBDA (NAME TYPE)                                    (* ; "Edited  5-Dec-86 06:20 by lmm")
    (PROG (TEM)
          (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
      LP  [COND
             ((SETQ TEM (fetch DELDEF of TYPE))
              (APPLY* TEM NAME TYPE))
             (T (SELECTQ TYPE
                    (FNS                                     (* ; 
  "special because GETDEF of a FNS is only its EXPR definition, and DELDEF should only remove such")
                         (AND (EXPRP NAME)
                              (/PUTD NAME))
                         (REMPROP NAME 'EXPR)
                         [AND MSDATABASELST (MASTERSCOPE (LIST 'ERASE (KWOTE NAME])
                    (VARS (/SETTOPVAL NAME 'NOBIND))
                    (FILES [for LST in '(FILELST NOTCOMPILEDFILES NOTLISTEDFILES)
                              do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST]
                           (/replace FILEPROP of NAME with NIL)
                           (/replace FILECHANGES of NAME with NIL)
                           (/replace FILEDATES of NAME with NIL)
                           (FLUSHFILEMAPS NAME))
                    (FILEPKGCOMS (DELFROMLIST 'FILEPKGCOMSPLST NAME)
                                 (DELFROMLIST 'FILEPKGTYPES NAME)
                                 (for FIELD on (FILEPKGCOM NAME)
                                    by (CDDR FIELD) do (FILEPKGCOM NAME (CAR FIELD)
                                                                      NIL))
                                 (for FIELD on (FILEPKGTYPE NAME)
                                    by (CDDR FIELD) do (FILEPKGTYPE NAME (CAR FIELD)
                                                                      NIL))
                                 (/replace ALLFIELDS of NAME with NIL))
                    (ALISTS [AND (LISTP NAME)
                                 (DELFROMLIST (CAR NAME)
                                        (FASSOC (CADR NAME)
                                               (GETTOPVAL (CAR NAME])
                    (MACROS (for P in MACROPROPS do (/REMPROP NAME P)))
                    (PROPS (AND (LISTP NAME)
                                (/REMPROP (CAR NAME)
                                       (CADR NAME))))
                    (LISPXMACROS (DELFROMLIST 'LISPXMACROS (FASSOC NAME LISPXMACROS))
                                 (DELFROMLIST 'LISPXHISTORYMACROS (FASSOC NAME LISPXHISTORYMACROS
                                                                             ))
                                 (DELFROMLIST 'LISPXCOMS NAME)
                                 (DELFROMLIST 'HISTORYCOMS NAME))
                    (PRIN1 (LIST "Note: deleting" TYPE "not implemented yet")
                           T]
          (MARKASCHANGED NAME TYPE 'DELETED)
          (RETURN NAME])

(DELFROMLIST
  [LAMBDA (VAR VAL)                                      (* rmk%: " 3-JAN-82 23:22")
    (AND (FMEMB VAL (GETTOPVAL VAR))
         (/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR)
                                (FUNCTION (LAMBDA (X)
                                            (AND (NEQ X VAL)
                                                 (OR (NLISTP X)
                                                     (NEQ (CDR X)
                                                          VAL])

(HASDEF
  [LAMBDA (NAME TYPE SOURCE SPELLFLG)                    (* ; "Edited 31-Aug-87 18:02 by drc:")

    (* ;; "is NAME the name of something of type TYPE?  NIL SOURCE means 0, not ?")

    (DECLARE (SPECVARS TYPE))
    (COND
       [[OR (LISTP TYPE)
            (LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE](* ; "ignore SPELLFLG")
        (for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
                                            (RETURN $$VAL]
       (T
        (PROG [(NODEF (fetch NULLDEF of TYPE))
               (OPTS '(NODWIM NOCOPY NOERROR HASDEF]
              (COND
                 ((NULL SOURCE)
                  (SETQQ SOURCE CURRENT)))
              (RETURN
               (SELECTQ SOURCE
                   ((CURRENT 0) 
                        [COND
                           ([OR
                             (MEMBER NAME (fetch CHANGED of TYPE))
                             (LET ((TM (fetch HASDEF of TYPE)))
                                  (COND
                                     (TM (APPLY* TM NAME TYPE SOURCE))
                                     [(NOT (LITATOM NAME))
                                      (SELECTQ TYPE
                                          (PROPS (AND (LISTP NAME)
                                                      (GETPROP (CAR NAME)
                                                             (CADR NAME))))
                                          ((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS 
                                                  FIELDS USERMACROS FILEVARS FILEPKGCOMS) 
                                               NIL)
                                          (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                                     (T 
                                        (* ;; "symbol definitions")

                                        (SELECTQ TYPE
                                            (FILES (LET ((SYMBOL (CL:FIND-SYMBOL (CONCAT NAME "COMS")
                                                                        "INTERLISP")))
                                                        (AND SYMBOL (BOUNDP SYMBOL))))
                                            (TEMPLATES (GETTEMPLATE NAME))
                                            (MACROS (GETLIS NAME MACROPROPS))
                                            (LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
                                                             (FASSOC NAME LISPXHISTORYMACROS)))
                                            (VARS (AND (NOT (CL:KEYWORDP NAME))
                                                       (NEQ (GETTOPVAL NAME)
                                                            'NOBIND)))
                                            (RECORDS (RECLOOK NAME))
                                            (I.S.OPRS [PROG [(TEM (GETPROP NAME 'CLISPWORD]
                                                            (RETURN (AND TEM (EQ (CAR TEM)
                                                                                 'FORWORD)
                                                                         (GETPROP (CDR TEM)
                                                                                'I.S.OPR])
                                            (FNS (AND (OR (AND (GETD NAME)
                                                               (EXPRP (GETD NAME)))
                                                          (GET NAME 'EXPR))
                                                      (NOT (HASDEF NAME 'FUNCTIONS SOURCE))))
                                            (FIELDS (RECORDFIELD? NAME))
                                            (USERMACROS (FASSOC NAME USERMACROS))
                                            (FILEVARS)
                                            ((PROPS ALISTS DEFS EXPRESSIONS) 
                                                 NIL)
                                            (FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
                                                             (FMEMB NAME FILEPKGTYPES)))
                                            (NEQ NODEF (GETDEF NAME TYPE 'CURRENT OPTS]
                            (OR NAME T))
                           (SPELLFLG (CL:WHEN (CL:SYMBOLP NAME)
                                         (FIXSPELL NAME NIL
                                                (SELECTQ TYPE
                                                    (FILES FILELST)
                                                    (FILEPKGCOMS (UNION FILEPKGCOMSPLST FILEPKGTYPES))
                                                    (FIELDS (for X in USERRECLST
                                                               join (APPEND (RECORDFIELDNAMES
                                                                                 X))))
                                                    (RECORDS (for X in USERRECLST
                                                                when (LITATOM (CADR X))
                                                                collect (CADR X)))
                                                    (LISPXMACROS LISPXCOMS)
                                                    (I.S.OPRS I.S.OPRLST)
                                                    (USERMACROS (MAPCAR USERMACROS
                                                                       (FUNCTION CAR)))
                                                    USERWORDS)
                                                NIL
                                                (LISTP SPELLFLG)
                                                [FUNCTION (LAMBDA (X)
                                                            (HASDEF X TYPE 'CURRENT]
                                                NIL T))])
                   (? (OR (HASDEF NAME TYPE 'CURRENT)
                          (AND (LITATOM NAME)
                               (HASDEF NAME TYPE 'SAVED SPELLFLG))
                          (WHEREIS NAME TYPE T)))
                   ((SAVED T) 
                        (NEQ NODEF (GETDEF NAME TYPE 'SAVED OPTS)))
                   (NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])

(GETFILEDEF
  [LAMBDA (FILENAME)                                     (* lmm " 4-Jul-85 13:25")

    (* ;; 
  "returns the official file name from a file name if NAME is FOO, look for FOO.LSP on FILELST")

    (COND
       ((FMEMB FILENAME FILELST)
        FILENAME)
       (T (for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T)
             do (COND
                       ((EQ (FILENAMEFIELD FILE 'NAME)
                            FILENAME)
                        (RETURN FILE])

(SAVEDEF
  [LAMBDA (NAME TYPE DEFINITION)                         (* JonL "24-Jul-84 20:11")
    (COND
       [(AND (LISTP NAME)
             (NULL TYPE))
        (MAPCAR NAME (FUNCTION (LAMBDA (I)
                                 (SAVEDEF I 'FNS]
       (T [SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
              (FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME)))
                        (/PUT NAME [SETQ TYPE (COND
                                                 ((SUBRP DEFINITION)
                                                  'SUBR)
                                                 ((EXPRP DEFINITION)
                                                  'EXPR)
                                                 ((CCODEP DEFINITION)
                                                  'CODE)
                                                 (T 'LIST]
                              DEFINITION)))
              (VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME)))
                              'NOBIND)
                         (EQ DEFINITION (GETTOPVAL NAME))
                         (/PUT NAME (SETQ TYPE 'VALUE)
                               DEFINITION)))
              (AND [OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE 'CURRENT
                                                          '(NOCOPY NOERROR NODWIM]
                   (/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS))
                                                  (CAR (SETQ SAVEDDEFS (CONS (LIST TYPE (CONS NAME))
                                                                             SAVEDDEFS]
          TYPE])

(UNSAVEDEF
  [LAMBDA (NAME TYPE DEF)                                (* lmm " 6-Jun-86 17:24")
    (SELECTQ TYPE
        ((NIL EXPR CODE SUBR LIST) 
             (COND
                [(LISTP NAME)                                (* ; "for compatibility")
                 (MAPCAR NAME (FUNCTION (LAMBDA (X)
                                          (UNSAVED1 X TYPE]
                (T (UNSAVED1 NAME TYPE))))
        (PROG NIL
              [OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
                                       'SAVED 0))
                  (RETURN (CONS TYPE '(not found]
              (COND
                 ((NEQ DFNFLG T)
                  (SAVEDEF NAME TYPE)
                  (LET ((DFNFLG T))
                       (PUTDEF NAME TYPE DEF)))
                 (T (PUTDEF NAME TYPE DEF)))
              (RETURN TYPE])

(COMPAREDEFS
  [LAMBDA (NAME TYPE SOURCES)                            (* lmm " 4-Jul-85 14:37")
    (COND
       ((AND (LISTP TYPE)
             (GETFILEPKGTYPE SOURCES NIL T))
        (swap TYPE SOURCES)))
    (SETQ TYPE (GETFILEPKGTYPE TYPE 'TYPE))
    (PROG [DEF DEFS (SRCS (OR SOURCES (WHEREIS NAME TYPE T]
          [COND
             ((NULL SOURCES)
              (AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE))
                       (SOME SRCS (FUNCTION (LAMBDA (FILE)
                                              (MEMBER NAME (CDR (ASSOC TYPE
                                                                       (fetch TOBEDUMPED
                                                                          of (fetch FILEPROP
                                                                                    of FILE]
                   (push SRCS 'CURRENT]
          (SETQ SRCS (for SRC in SRCS
                        when (COND
                                    ((NEQ [SETQ DEF (GETDEF NAME TYPE SRC '(NOERROR NOCOPY]
                                          (fetch NULLDEF of TYPE))
                                     (OR [SOME DEFS (FUNCTION (LAMBDA (DP)
                                                                (COMPARELST DEF (CDR DP]
                                         (push DEFS (CONS SRC DEF)))
                                     T)
                                    (T (PRINTOUT T "No " SRC " definition found for " NAME T)
                                       NIL)) collect SRC))
          (RETURN (COND
                     ((NULL SRCS)
                      '(no definitions found))
                     ((NULL (CDR SRCS))
                      '(only one definition found))
                     ((CDR DEFS)
                      [for S1 on (DREVERSE DEFS)
                         do (for S2 on (CDR S1) do (PRIN2 NAME T T)
                                                                  (AND (CAAR S1)
                                                                       (PRIN1 " from " T)
                                                                       (PRIN2 (CAAR S1)
                                                                              T T))
                                                                  (PRIN1 " and " T)
                                                                  (PRIN2 NAME T T)
                                                                  (COND
                                                                     ((CAAR S2)
                                                                      (PRIN1 " from " T)
                                                                      (PRIN2 (CAAR S2)
                                                                             T T)))
                                                                  (PRIN1 " differ:" T)
                                                                  (TERPRI T)
                                                                  (COMPARELISTS (CDAR S1)
                                                                         (CDAR S2]
                      'DIFFERENT)
                     (T 'SAME])

(COMPARE
  [LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2)             (* lmm " 5-SEP-78 13:37")
    (PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 '(NOERROR NOCOPY]
           (DEF2 (GETDEF NAME2 TYPE SOURCE2 '(NOERROR NOCOPY]
          (COND
             ((COMPARELST DEF1 DEF2)
              (RETURN)))
          (PRIN2 NAME1 T T)
          (COND
             (SOURCE1 (PRIN1 " from " T)
                    (PRIN2 SOURCE1 T T)))
          (PRIN1 " and " T)
          (PRIN2 NAME2 T T)
          (COND
             (SOURCE2 (PRIN1 " from " T)
                    (PRIN2 SOURCE2 T T)))
          (PRIN1 " differ:" T)
          (TERPRI T)
          (COMPARELISTS DEF1 DEF2)
          (RETURN T])

(TYPESOF
  [LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE FILTER)
                                                          (* ; "Edited  2-Aug-88 02:08 by masinter")

    (* ;; "return list of all known types which NAME names")

    (LET
     (FOUND SHADOWED)
     (if (FMEMB SOURCE '(? NIL))
         then (CL:FLET [(RSHADOW NIL (for X in FOUND
                                            do (for Y in (CDR (FASSOC X SHADOW-TYPES))
                                                      do (if (FMEMB Y FOUND)
                                                                 then 
                                                             (* ; "shadower found before shadowed")
                                                                       (SETQ FOUND (REMOVE Y FOUND]
                         (LET (NOTFOUND NEWTYPES)
                              (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                                 when [AND (LITATOM TYPE)
                                               (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                               (OR (NULL FILTER)
                                                   (CL:FUNCALL FILTER TYPE))
                                               (NOT (find X in FOUND
                                                       suchthat (FMEMB TYPE
                                                                           (CDR (FASSOC X 
                                                                                       SHADOW-TYPES]
                                 do (if [OR (HASDEF NAME TYPE 'CURRENT)
                                                    (AND (LITATOM NAME)
                                                         (HASDEF NAME TYPE 'SAVED]
                                            then (push FOUND TYPE)
                                          else (push NOTFOUND TYPE)))
                              (RSHADOW)
                              [for FILE in FILELST while NOTFOUND
                                 when [NEQ T (fetch LOADTYPE of (GETPROP FILE
                                                                                   'FILE]
                                 do (if (SETQ NEWTYPES (INFILECOMS? NAME NOTFOUND
                                                                      (FILECOMS FILE)
                                                                      'TYPESOF))
                                            then [bind X for TYPE in NEWTYPES
                                                        when (FMEMB TYPE NOTFOUND)
                                                        do (push FOUND TYPE)
                                                              (if (SETQ X (FASSOC TYPE 
                                                                                     SHADOW-TYPES))
                                                                  then (SETQ NOTFOUND
                                                                            (LDIFFERENCE NOTFOUND X))
                                                                else (SETQ NOTFOUND
                                                                          (REMOVE TYPE NOTFOUND]
                                                  (SETQ NOTFOUND (LDIFFERENCE NOTFOUND NEWTYPES]
                              (if (AND NOTFOUND (GETD 'XCL::HASH-FILE-TYPES-OF))
                                  then (SETQ NEWTYPES (XCL::HASH-FILE-TYPES-OF NAME NOTFOUND))
                                        (SETQ FOUND (UNION NEWTYPES FOUND)))
                              (RSHADOW)
                              FOUND))
       else (for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES)
                   when (AND (LITATOM TYPE)
                                 (NOT (EQMEMB TYPE IMPOSSIBLETYPES))
                                 (OR (NULL FILTER)
                                     (CL:FUNCALL FILTER TYPE))
                                 (HASDEF NAME TYPE SOURCE)) do (push FOUND TYPE)))
     FOUND])
)

(RPAQ? WHEREIS.HASH )



(* ; "Must come after PUTDEF")

(DEFINEQ

(FIXEDITDATE
  [LAMBDA (EXPR)                                         (* ; "Edited 17-Jul-89 11:13 by jtm:")
                                                             (* NOBIND "18-JUL-78 21:11")
                                                             (* Inserts or replaces previous edit 
                                                           date)
    (AND INITIALS (LISTP EXPR)
         (LISTP (CDR EXPR))
         (PROG (E)
               (COND
                  ((FMEMB (CAR EXPR)
                          LAMBDASPLST)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR)))
                  [(FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-ARGLIST-DEFINERS)

                   (* ;; "insert the edit date after the argument list")

                   (SETQ E (CDDR EXPR))
                   (while (NOT (CL:LISTP (CAR E))) do (SETQ E (CDR E))
                      finally (SETQ E (CDR E]
                  ((FMEMB (GETPROP (CAR EXPR)
                                 ':DEFINER-FOR)
                          EDITDATE-NAME-DEFINERS)

                   (* ;; "insert the edit date after the name")

                   (SETQ E (CDDR EXPR)))
                  (T (RETURN)))
           RETRY
               [COND
                  ((NLISTP E)
                   (RETURN))
                  ((LISTP (CAR E))
                   (SELECTQ (CAAR E)
                       ((CLISP%: DECLARE) 
                            (SETQ E (CDR E))
                            (GO RETRY))
                       (BREAK1 (COND
                                  ((EQ (CAR (CADAR E))
                                       'PROGN)
                                   (SETQ E (CDR (CADAR E)))
                                   (GO RETRY))))
                       (ADV-PROG                             (* No easy way to mark cleanly the 
                                                           date of an advised function)
                                 (RETURN))
                       (COND
                          ((AND (EQ (CAAR E)
                                    COMMENTFLG)
                                (EQ (CADAR E)
                                    'DECLARATIONS%:))
                           (SETQ E (CDR E))
                           (GO RETRY]
               (COND
                  ([for TAIL on E while (AND (LISTP (CAR TAIL))
                                                         (EQ (CAAR TAIL)
                                                             COMMENTFLG))
                      do (COND
                                ((AND (LISTP (CDR TAIL))
                                      (EDITDATE? (CAR TAIL)))
                                 (/RPLACA TAIL (EDITDATE (CAR TAIL)
                                                      INITIALS))
                                 (RETURN T]                  (* scans the comments for a 
                                                           timestamp for this user.)
                   NIL)
                  (T                                         (* attach the new timestamp at the 
                                                           beginning of the comments.)
                     (/ATTACH (EDITDATE NIL INITIALS)
                            E)))
               (RETURN EXPR])

(EDITDATE?
  [LAMBDA (COMMENT)                                      (* ; "Edited 11-Jun-92 16:44 by cat")
                                                             (* ; "Edited 13-Jul-89 09:30 by jtm:")
                                                             (* lmm "21-Mar-85 08:45")

         (* Tests to see if a given common is in fact an edit date --
       this has to be general enough to recognize the most comment comment forms while 
       specific enough to not recognize things that are not edit dates)

    (DECLARE (LOCALVARS . T))                            (* jtm%: changed test so that it 
                                                           creates one timestamp per user.)
    (COND
       [(LISTP COMMENT)
        (COND
           ((EQ (CAR COMMENT)
                COMMENTFLG)
            [COND
               (NIL (NULL NORMALCOMMENTSFLG)
                    (SETQ COMMENT (GETCOMMENT COMMENT]
            (COND
               ([OR (NOT (LISTP (CDR COMMENT)))
                    (NOT (LISTP (CDDR COMMENT]
                NIL)
               [(EQ (CADR COMMENT)
                    ';)                                      (* ; "CL style comment")
                (STRPOS INITIALS (CADDR COMMENT)
                       (IMINUS (NCHARS INITIALS]
               (T                                            (* ; "IL style comment")
                  (EQ (CADR COMMENT)
                      INITIALS]
       ((STRINGP COMMENT])
)



(* ; "Edit date support for all kinds of definers (from PARC 6/10/92)")


(RPAQQ EDITDATE-ARGLIST-DEFINERS (FUNCTIONS TYPES))

(RPAQQ EDITDATE-NAME-DEFINERS (STRUCTURES VARIABLES))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EDITDATE-ARGLIST-DEFINERS EDITDATE-NAME-DEFINERS)
)



(* ;; 
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS in order to get started."
)

(DEFINEQ

(FILEPKGCOM
  [LAMBDA N                                              (* JonL "10-Jul-84 19:38")
    (PROG (TEM (COM (ARG N 1)))
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in '(MACRO CONTENTS DELETE ADD)
                             when (SETQ TEM (FILEPKGCOM COM FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                               (LIST 'COM T))
                          (AND [SETQ TEM (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                               (LIST 'COM TEM]
                     ((EQ N 2)
                      (SELECTQ (ARG N 2)
                          (ADD (fetch ADD of COM))
                          (DELETE (fetch DELETE of COM))
                          (MACRO (fetch MACRO of COM))
                          ((CONTENTS CONTAIN) 
                               [OR (fetch (FILEPKGCOM CONTENTS) of COM)
                                   (COND
                                      ((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM))
                                       (COND
                                          ((EQ COM 'NILL)
                                           COM)
                                          [(EQ (CAR COM)
                                               'LAMBDA)
                                           (CONS (CAR COM)
                                                 (CONS [CONS (CAADR COM)
                                                             (CONS (OR (CADDR (CADR COM))
                                                                       'NAME)
                                                                   (CONS (CADR (CADR COM))
                                                                         (CDDDR (CADR COM]
                                                       (SUBST 'INFILECOMTAIL 'PRETTYCOM1 (CDDR COM]
                                          (T (LIST 'LAMBDA '(COM TYPE NAME)
                                                   (CONS COM '(COM TYPE NAME])
                          (COM [OR (AND (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                        T)
                                   (CDR (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST])
                          (ERROR (ARG N 2)
                                 "not file package command property")))
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'COM)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T [OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                (/SETTOPVAL 'FILEPKGCOMSPLST
                                                       (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST])
                                         (COND
                                            ([SETQ TEM2 (ASSOC COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGCOMSPLST
                                                      (CONS (CONS COM TEM)
                                                            (GETTOPVAL 'FILEPKGCOMSPLST]
                                    (T [AND TEM (OR (FMEMB COM (GETTOPVAL 'FILEPKGCOMSPLST))
                                                    (/SETTOPVAL 'FILEPKGCOMSPLST
                                                           (CONS COM (GETTOPVAL 'FILEPKGCOMSPLST]
                                       (SELECTQ (ARG N I)
                                           (ADD (/replace (FILEPKGCOM ADD) of COM
                                                   with TEM))
                                           (DELETE (/replace (FILEPKGCOM DELETE) of
                                                                                         COM
                                                      with TEM))
                                           (MACRO (/replace (FILEPKGCOM MACRO) of COM
                                                     with TEM))
                                           ((CONTENTS CONTAIN) 
                                                (/replace (FILEPKGCOM CONTENTS) of COM
                                                   with TEM))
                                           (ERROR (ARG N I)
                                                  "not file package command property"]
                        (MARKASCHANGED COM 'FILEPKGCOMS])

(FILEPKGTYPE
  [LAMBDA N                                              (* lmm " 5-Jul-85 09:07")
    (PROG ((TYPE (ARG N 1))
           TEM)
          (RETURN (COND
                     [(EQ N 1)
                      (OR (for FIELD in (UNION '(DESCRIPTION)
                                                       FILEPKGTYPEPROPS)
                             when (SETQ TEM (FILEPKGTYPE TYPE FIELD))
                             join (LIST FIELD TEM))
                          (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                               (LIST 'TYPE T))
                          (AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES]
                               (LIST 'TYPE TEM]
                     [(EQ N 2)
                      (if (FMEMB (ARG N 2)
                                     FILEPKGTYPEPROPS)
                          then (GETPROP TYPE (ARG N 2))
                        else (SELECTQ (ARG N 2)
                                     (DESCRIPTION (fetch DESCRIPTION of TYPE))
                                     (TYPE [OR (AND (FMEMB TYPE (GETTOPVAL 'FILEPKGTYPES))
                                                    T)
                                               (CDR (ASSOC TYPE (GETTOPVAL 'FILEPKGTYPES])
                                     (ERROR (ARG N 2)
                                            "not file package type property"]
                     (T [for I TEM2 from 2 to N by 2
                           do (SETQ TEM (ARG N (ADD1 I)))
                                 (COND
                                    [(EQ (ARG N I)
                                         'TYPE)
                                     (SELECTQ TEM
                                         (NIL)
                                         (T (OR (FMEMB TYPE FILEPKGTYPES)
                                                (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES))))
                                         (COND
                                            ((SETQ TEM2 (ASSOC TYPE FILEPKGTYPES))
                                             (/RPLACD TEM2 TEM))
                                            (T (/SETTOPVAL 'FILEPKGTYPES (CONS (CONS TYPE TEM)
                                                                               FILEPKGTYPES]
                                    (T [AND TEM (OR (FMEMB TYPE FILEPKGTYPES)
                                                    (/SETTOPVAL 'FILEPKGTYPES (CONS TYPE FILEPKGTYPES
                                                                                    ]
                                       (if (FMEMB (ARG N I)
                                                      FILEPKGTYPEPROPS)
                                           then (if TEM
                                                        then (/PUTPROP TYPE (ARG N I)
                                                                        TEM)
                                                      else (/REMPROP TYPE (ARG N I)))
                                         else (SELECTQ (ARG N I)
                                                      (DESCRIPTION (/replace DESCRIPTION
                                                                      of TYPE with TEM))
                                                      (ERROR (ARG N I)
                                                             "not file package command/type property"
                                                             ]
                        (MARKASCHANGED TYPE 'FILEPKGCOMS])
)

(PUTPROPS FILEPKGCOM ARGNAMES (COMMANDNAME (KEYWORDS%: MACRO ADD DELETE CONTENTS)))

(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)

(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) '([COM CONTENTS (LAMBDA (COM NAME TYPE)
                                                                       (* Revert to NILL when no 
                                                                          longer coercing 
                                                                          PRETTYDEFMACROS to 
                                                                          FILEPKGCOMS)
                                                                       (AND (EQ TYPE 'FILEPKGCOMS)
                                                                            (INFILECOMTAIL COM]
                                                  (TYPE DESCRIPTION "file package commands/types" 
                                                        GETDEF T PUTDEF FILEPKGCOMS.PUTDEF)))
(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEALISTCOMS . X]
                                             (TYPE DESCRIPTION "alist entries" GETDEF ALISTS.GETDEF 
                                                   WHENCHANGED (ALISTS.WHENCHANGED))))
(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS . X])
(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) '((TYPE TYPE USERMACROS)))
(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) '((TYPE DESCRIPTION "expressions" WHENCHANGED (
                                                                              EXPRESSIONS.WHENCHANGED
                                                                                               )
                                                        EDITDEF NILL)))
(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) '((TYPE EDITDEF NILL)))
(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)
                                                   (TYPE TYPE FILEPKGCOMS)))
(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) '([COM MACRO [X (P * (CONS (MAKEFILESCOMS . X]
                                                 CONTENTS
                                                 (LAMBDA (COM NAME TYPE)
                                                        (AND (EQ TYPE 'FILES)
                                                             (SUBSET (INFILECOMTAIL COM)
                                                                    (FUNCTION LITATOM]
                                            (TYPE PUTDEF FILES.PUTDEF WHENCHANGED (FILES.WHENCHANGED)
                                                  EDITDEF EDITDEF.FILES)))
(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (VARS . X)))
                                               (TYPE NULLDEF NOBIND EDITDEF NILL)))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (FN)
                                                                         (AND (GETPROP FN
                                                                                     'FUNCTIONS)
                                                                              (CL:WARN 
                                                                      "~A has a FUNCTIONS definition"
                                                                                     FN]
                                                  (ORIGINAL (FNS . X)))
                                               CONTENTS NILL)
                                          (TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF CANFILEDEF
                                                T)))
(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (P * (RECORDALLOCATIONS . X)))
                                                       CONTENTS
                                                       (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                              (AND (NULL ONFILETYPE)
                                                                   (EQ TYPE 'RECORDS)
                                                                   (INFILECOMTAIL COM])
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) '((TYPE TYPE LISPXMACROS)))
(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS . X)))
                                                       CONTENTS NILL)
                                                  (TYPE DESCRIPTION "LISPX commands")))
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) '((COM
                                              MACRO
                                              [X
                                               (DECLARE%:
                                                EVAL@COMPILE
                                                (P
                                                 *
                                                 (MAPCAR
                                                  'X
                                                  (FUNCTION
                                                   (LAMBDA (Y)
                                                          (LET [[FNDEF (GETDEF Y 'FUNCTIONS
                                                                              'CURRENT
                                                                              '(NOCOPY NOERROR]
                                                                (MACDEF (GETDEF Y 'MACROS
                                                                               'CURRENT
                                                                               '(NOCOPY NOERROR]
                                                               (COND
                                                                ((AND FNDEF (EQ (CAR FNDEF)
                                                                                'DEFMACRO))
                                                                 (CL:WARN 
                           "Need to change MACROS to FUNCTIONS for writing out Common Lisp macro ~S."
                                                                        FNDEF)
                                                                 (LIST 'PROGN FNDEF MACDEF))
                                                                (T (OR MACDEF (CL:CERROR 
                                                          "Go ahead and finish writing out the file."
                                                                                     
                                                                       "No MACROS definition for ~A."
                                                                                     Y)
                                                                       (GETDEF Y 'MACROS 'CURRENT]
                                              CONTENTS NILL)
                                             (TYPE DESCRIPTION "Interlisp macros" GETDEF 
                                                   MACROS.GETDEF WHENCHANGED (CLEARCLISPARRAY))))
(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) '((COM COM FILEPKGCOMS)))
(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) '([COM MACRO (X (COMS * (MAKEPROPSCOMS . X]
                                            (TYPE DESCRIPTION "property lists" WHENCHANGED (
                                                                                    PROPS.WHENCHANGED
                                                                                            ))))
(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) '[[COM
                                               MACRO
                                               (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                         (RECORD)
                                                                         (AND (GETPROP RECORD
                                                                                     'STRUCTURES)
                                                                              (CL:WARN 
                                                                     "~A has a STRUCTURES definition"
                                                                                     RECORD]
                                                  (E (RECORDECLARATIONS . X))
                                                  (INITRECORDS . X))
                                               CONTENTS
                                               (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                      (AND (EQ TYPE 'FIELDS)
                                                           (NULL ONFILETYPE)
                                                           (MAPCONC (INFILECOMTAIL COM)
                                                                  (FUNCTION (LAMBDA
                                                                             (X)
                                                                             (APPEND (
                                                                                     RECORDFIELDNAMES
                                                                                      X]
                                              (TYPE DESCRIPTION "records" DELDEF
                                                    (LAMBDA (X)
                                                           (/SETTOPVAL 'USERRECLST
                                                                  (REMOVE (RECLOOK X)
                                                                         USERRECLST])
(PUTDEF (QUOTE OLDRECORDS) (QUOTE FILEPKGCOMS) '((COM COM T)))
(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (SAVEONSYSRECLST . X)))
                                                      CONTENTS
                                                      (LAMBDA (COM NAME TYPE ONFILETYPE)
                                                             (AND (NULL ONFILETYPE)
                                                                  (EQ TYPE 'RECORDS)
                                                                  (INFILECOMTAIL COM])
(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X)))
                                                      CONTENTS NILL)
                                                 (TYPE DESCRIPTION "edit macros")))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO
                                                (X [E (MAPC 'X (FUNCTION (LAMBDA
                                                                          (VAR)
                                                                          (AND (GETPROP VAR
                                                                                      'VARIABLES)
                                                                               (CL:WARN 
                                                                 "~A also has a VARIABLES definition"
                                                                                      VAR]
                                                   (ORIGINAL (VARS . X)))
                                                CONTENTS NILL)
                                           (TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF 
                                                 VARS.PUTDEF)))
(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) '((COM CONTENTS NILL)))
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: EVAL@COMPILE (VARS . X)
                                                                     (P (CONSTANTS . X])

(ADDTOVAR SHADOW-TYPES (FUNCTIONS FNS)
                           (VARIABLES VARS CONSTANTS))

(RPAQ? SAVEDDEFS )



(* ; "EDITCALLERS")

(DEFINEQ

(FINDCALLERS
  [LAMBDA (ATOMS FILES)                                  (* lmm "30-SEP-78 01:36")
    (PROG ((X (EDITCALLERS ATOMS FILES T)))
          (RETURN (NCONC (DREVERSE (CDR X))
                         (AND (CAR X)
                              (LIST (CONS (COND
                                             ((CDR X)
                                              '"plus other places on")
                                             (T 'on))
                                          (CAR X])

(EDITCALLERS
  [LAMBDA (ATOMS FILES COMS)                            (* ; "Edited  8-Aug-2020 17:32 by rmk:")
                                                             (* bvm%: " 3-Nov-86 17:30")
    (LET
     (FFILEPOSPATTERNS FNS OTHERSFILES EDITPATTERN)
     [SETQ EDITPATTERN (EDITFPAT (CONS '*ANY* (SETQ ATOMS (MKLIST ATOMS]
     [for FILE in (COND
                             ((NULL FILES)
                              FILELST)
                             ((EQ FILES T)
                              (UNION SYSFILES FILELST))
                             ((LISTP FILES)
                              FILES)
                             (T (LIST FILES)))
        do
        (RESETLST
            [PROG (PATTERNS CA RDTBL MAP NOMAPFLG FULL FILESTREAM PRINTFLG ENV DUMMY TOP I)
                  (OR (SETQ FULL (FINDFILE FILE))
                      (RETURN (LISPXPRINT (CONS FILE '(not found))
                                     T T)))
                  [RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                       (SETQ FILESTREAM (OPENSTREAM FULL 'INPUT]
                  (CL:FORMAT T "~A: " (SETQ FULL (FULLNAME FILESTREAM)))
                  (CL:MULTIPLE-VALUE-SETQ (ENV MAP TOP)
                         (OR (GET-ENVIRONMENT-AND-FILEMAP FULL)
                             (\PARSE-FILE-HEADER FILESTREAM)))

             (* ;; "Get reader environment of file.  The call to GET-ENVIRONMENT-AND-FILEMAP with the filename will get cached info if it exists.  Otherwise, read the top of the file")

                  (SETQ RDTBL (AND ENV (fetch (READER-ENVIRONMENT REREADTABLE) of ENV)))
                  (SETQ CA (SEPRCASE DWIMIFYCOMPFLG RDTBL))
                  [OR (SETQ PATTERNS (CDR (ASSOC RDTBL FFILEPOSPATTERNS)))
                      (push FFILEPOSPATTERNS
                             (CONS RDTBL (SETQ PATTERNS
                                          (for ATOM in ATOMS
                                             collect (CONCAT
                                                          (COND
                                                             ((EQ (CHCON1 ATOM)
                                                                  (CHARCODE ESCAPE))
                                                              (SETQ ATOM (SUBSTRING ATOM 2 -1))
                                                              "")
                                                             (T " "))
                                                          [COND
                                                             ((SETQ I (STRPOS ' ATOM))
                                                              (SUBSTRING ATOM 1 (SUB1 I)))
                                                             ((STRINGP ATOM))
                                                             (T (LET ((*PACKAGE* (CL:SYMBOL-PACKAGE
                                                                                  ATOM)))
                                                             (* ; 
                                                           "Keep MKSTRING from putting a prefix on")
                                                                     (MKSTRING ATOM T RDTBL]
                                                          (COND
                                                             (I "")
                                                             (T " "]
                  (for PATTERN in PATTERNS
                     do
                     (SETFILEPTR FILESTREAM (SETQ I (OR TOP 0)))
                     (while (SETQ I (FFILEPOS PATTERN FILESTREAM I NIL NIL T CA))
                        do
                        (COND
                           ((NULL PRINTFLG)                  (* ; 
                                   "cause the printing of the filename to be saved on history list")
                            (SETQ PRINTFLG T)
                            (LISPXPRIN2 FULL T T T)

                            (* ;; "print with NODOFLG=T means just to record the printing;  the idea is that only those files in which something is found will be remembered on the history list")

                            (LISPXPRIN1 ": " T NIL T)))
                        [OR
                         [AND (NEQ MAP T)
                              (for X in (CDR (OR MAP [PROGN (SETFILEPTR FILESTREAM 0)
                                                                    (SETQ MAP (OR (GETFILEMAP 
                                                                                         FILESTREAM)
                                                                                  (LOADFILEMAP 
                                                                                         FILESTREAM]
                                                         (PROGN 
                                                             (* ; "file has no filemap")
                                                                (SETQ MAP (SETQ NOMAPFLG T))
                                                                (LISPXPRIN1 " no filemap!" T)
                                                                NIL)))
                                 thereis (AND (ILESSP (CAR X)
                                                         I)
                                                  (IGREATERP (CADR X)
                                                         I)
                                                  (for Z in (CDDR X)
                                                     thereis (COND
                                                                    ((AND (ILESSP (CADR Z)
                                                                                 I)
                                                                          (IGREATERP (CDDR Z)
                                                                                 I))
                                                                     [COND
                                                                        ((NOT (FMEMB (CAR Z)
                                                                                     FNS))
                                                                         (SETQ FNS
                                                                          (CONS (LISPXPRIN2
                                                                                 (CAR Z)
                                                                                 T T)
                                                                                FNS]
                                                                     (SETQ I (CDDR Z))
                                                                     T]
                         (PROGN (LISPXPRIN2 I T T)
                                (OR (FMEMB FILE OTHERSFILES)
                                    (SETQ OTHERSFILES (CONS FILE OTHERSFILES]
                        (LISPXSPACES 1 T)))
                  (COND
                     (PRINTFLG (LISPXTERPRI T))
                     (T (TERPRI T)))
                  (COND
                     ((NEQ COMS T)
                      (COND
                         ((OR FNS OTHERSFILES)
                          (EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS))
                                 FULL EDITPATTERN COMS (NULL OTHERSFILES))
                          (SETQ OTHERSFILES)
                          (SETQ FNS])]
     (COND
        ((EQ COMS T)
         (CONS OTHERSFILES FNS])

(EDITFROMFILE
  [LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES)     (* rmk%: "14-Mar-85 21:51")
    (RESETVARS [(EDITLOADFNSFLG (COND
                                   ((EQ EDITLOADFNSFLG T)
                                    '(T . NO))
                                   (T EDITLOADFNSFLG]
               (PROG NIL
                     [OR EDITCOMS (SETQ EDITCOMS (LIST (LIST 'EXAM EDITPATTERN]
                     (AND
                      (SETQ FILES (for FILE inside (OR FILES FILELST)
                                     when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE)
                                                                             FILELST))
                                                  (COND
                                                     ((EQ 'Y (ASKUSER DWIMWAIT 'Y (LIST "load from" 
                                                                                        FILE)
                                                                    NIL T))
                                                      (LOADFROM FILE FNS 'ALLPROP)
                                                      T))) collect FILE))
                      (for TYPE in [COND
                                              ((LISTP ONLYTYPES))
                                              (ONLYTYPES '(FNS))
                                              (T 

                                 (* ;; "Move FNS to the front.  This means that all the fns will be dwimified and edited before anything else (like a rename of fields) is done.")

                                                 (CONS 'FNS (REMOVE 'FNS FILEPKGTYPES]
                         when (AND (LITATOM TYPE)
                                       (NEQ (fetch EDITDEF of TYPE)
                                            'NILL))
                         do
                         (PROG (SEEN)
                               (for FILE inside FILES
                                  do
                                  (for NAME in [COND
                                                          ((AND (EQ TYPE 'FNS)
                                                                (NEQ FNS T))
                                                             (* ; 
                                                    "for this type, we are given the list of items")
                                                           (PROG1 FNS (SETQ FNS NIL)))
                                                          (T (* ; 
                             "only want the values of `TYPE' which are not part of some other type")
                                                             (FILECOMSLST FILE TYPE 'EDIT]
                                     unless (MEMBER NAME SEEN)
                                     do
                                     (ERSETQ
                                      (PROG [(DEF (OR (GETDEF NAME TYPE 'CURRENT
                                                             '(NOCOPY NOERROR))
                                                      (GETDEF NAME TYPE 'SAVED
                                                             '(NOCOPY NOERROR]

                                 (* ;; "If definition has been loaded, it may have been editted.  Work on that explicitly instead of bringing in a file definition to smash the users previous changes.  Perhaps we should query the user about this, but until the interaction is worked out, it is better to avoid trashing his in core edits, given that he can always get the file definition from permanent storage with LOADFNS.  --- We might also be more discriminating about this: if the user specified a root file name, then he means the definition from the definition group, not the physical file.  But ...  rmk")

                                            (COND
                                               ((OR (AND (EQ TYPE 'FNS)
                                                         (NEQ FNS T))
                                                    (AND (LISTP DEF)
                                                         (LOOKIN DEF EDITPATTERN)))
                                                (COND
                                                   ((NULL SEEN)
                                                    (LISPXPRIN1 "editing the " T)
                                                    (LISPXPRIN1 (OR (fetch DESCRIPTION
                                                                       of TYPE)
                                                                    TYPE)
                                                           T)
                                                    (LISPXSPACES 1 T)))
                                                (SETQ SEEN (CONS NAME SEEN))
                                                (LISPXPRIN2 NAME T T)
                                                (LISPXPRIN1 ":
" T)
                                                (COND
                                                   ((NOT
                                                     (ERSETQ (EDITDEF
                                                              NAME TYPE
                                                              (OR (AND DEF (CONS '= DEF))
                                                                  FILE)
                                                              EDITCOMS)))
                                                    (LISPXPRIN1 "failed" T)))
                                                (LISPXTERPRI T])

(FINDATS
  [LAMBDA (X L)                                          (* lmm "11-FEB-78 16:03")
    (COND
       ((NLISTP X)
        (FMEMB X L))
       (T (OR (FINDATS (CAR X)
                     L)
              (FINDATS (CDR X)
                     L])

(LOOKIN
  [LAMBDA (X PAT)                                        (* lmm "11-MAR-78 14:20")
    (COND
       ([AND (EQ (CAR PAT)
                 '*ANY*)
             (EVERY (CDR PAT)
                    (FUNCTION (LAMBDA (X)
                                (AND (LITATOM X)
                                     (NOT (STRPOS ' X]
        (FINDATS X (CDR PAT)))
       (T (EDITFINDP X PAT T])
)
(DEFINEQ

(SEPRCASE
  [LAMBDA (CLFLG RDTBL)                                  (* bvm%: "24-Oct-86 18:16")

    (* ;; "make a case array for FFILEPOS in which all of the seprs, breaks, and (possibly) clisp chars are all equivalent.  Based on FILERDTBL, but others are close with respect to breaks and seprs")

    (OR RDTBL (SETQ RDTBL FILERDTBL))
    (OR [ARRAYP (CDR (ASSOC RDTBL (COND
                                     (CLFLG CLISPCASEARRAYS)
                                     (T SEPRCASEARRAYS]
        (LET ((CA (CASEARRAY)))
             [if (READTABLEPROP RDTBL 'CASEINSENSITIVE)
                 then                                    (* ; "map upper into lower case")
                       (for I from (CHARCODE A) to (CHARCODE Z)
                          do (SETCASEARRAY CA I (+ I (- (CHARCODE a)
                                                            (CHARCODE A]
             (for X in (NCONC (AND CLFLG (for Y in CLISPCHARS
                                                    collect (CHCON1 Y)))
                                      (GETSEPR RDTBL)
                                      (GETBRK RDTBL)) do (SETCASEARRAY CA X 0))
             (if *PACKAGE*
                 then                                    (* ; 
                               "symbols qualified with package prefix will otherwise be unfindable")
                       (SETCASEARRAY CA (READTABLEPROP RDTBL 'PACKAGECHAR)
                              0))
             (SETQ CA (CONS RDTBL CA))
             (COND
                (CLFLG (push CLISPCASEARRAYS CA))
                (T (push SEPRCASEARRAYS CA)))
             (CDR CA])
)

(RPAQ? DEFAULTRENAMEMETHOD '(EDITCALLERS CAREFUL))

(RPAQ? SEPRCASEARRAYS )

(RPAQ? CLISPCASEARRAYS )

(MOVD? 'INFILEP 'FINDFILE)

                                                             (* ; "or else from SPELLFILE")
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
       (NOLINKFNS LOADFROM))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SYSFILES CLISPCASEARRAYS SEPRCASEARRAYS CLISPCHARS)
)



(* ; "EXPORT")

(DEFINEQ

(IMPORTFILE
  [LAMBDA (FILE RETURNFLG)                               (* lmm " 6-Jun-86 17:43")
    (RESETLST
        [RESETSAVE NIL (LIST 'CLOSEF (SETQ FILE (OPENSTREAM FILE 'INPUT]
        (RESETSAVE (INPUT FILE))                             (* ; 
                "Reset INPUT in case some form on the file's action is to read the next expression")
        (NCONC [COND
                  ((EQ RETURNFLG T)                          (* ; 
                                           "Just creating EXPORTS.ALL, don't side-effect the world")
                   (IMPORTFILESCAN FILE RETURNFLG))
                  (T (LET (FILEPKGFLG DFNFLG)
                          (IMPORTFILESCAN FILE RETURNFLG]
               (IMPORTEVAL [LIST 'PUTPROP (KWOTE (ROOTFILENAME FILE))
                                     ''IMPORTDATE
                                     (LIST 'IDATE (GETFILEINFO FILE 'CREATIONDATE]
                      RETURNFLG)))])

(IMPORTEVAL
  [LAMBDA (FORM RETURNFLG)                               (* ; "Edited  2-May-87 18:57 by Pavel")

    (* ;; "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")

    (AND (LISTP FORM)
         (SELECTQ (CAR FORM)
             (DECLARE%: (FOR Z IN (CDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (CL:EVAL-WHEN (FOR Z IN (CDDR FORM) JOIN (IMPORTEVAL Z RETURNFLG)))
             (/DECLAREDATATYPE                               (* ; 
                    "Ignore datatype initializations -- we only need the record declaration itself")
                  NIL)
             (PROGN                                          (* ; "default: eval and/or return it")
                    (AND (NEQ RETURNFLG T)
                         (EVAL FORM))
                    (AND RETURNFLG (LIST FORM])

(IMPORTFILESCAN
  [LAMBDA (FILE RETURNFLG)                               (* bvm%: "24-Oct-86 19:31")
    (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE)
        (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF
           join (until (EQUAL (SETQ DEF (READ FILE))
                                      ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))])

(CHECKIMPORTS
  [LAMBDA (FILES NOASKFLG)                               (* rmk%: "19-FEB-83 16:31")
                                                             (* ; 
                                           "Loads exported definitions from new versions of FILES.")
    (COND
       ((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE
                            when [AND (SETQ FULLFILENAME (FINDFILE FILE T))
                                          (OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE)
                                                                     'IMPORTDATE]
                                              (NOT (IEQP DATE (GETFILEINFO FULLFILENAME 
                                                                     'ICREATIONDATE]
                            collect (LIST FILE FULLFILENAME)))
             (OR NOASKFLG (SELECTQ (ASKUSER 5 'Y (LIST "load new exports from "
                                                       (MAPCAR FILES (FUNCTION CAR)))
                                          '((Y "es
")
                                            (N "o
"))
                                          T)
                              (N NIL)
                              T)))
        (for FILE in FILES do (IMPORTFILE (CADR FILE])

(GATHEREXPORTS
  [LAMBDA (FROMFILES TOFILE FLG)                         (* bvm%: "14-Oct-86 23:12")
                                                             (* ; 
                                        "Copies all exported definitions from FROMFILES to TOFILE.")
    (RESETLST
        [RESETSAVE NIL (LIST (FUNCTION CLOSE-AND-MAYBE-DELETE)
                             (SETQ TOFILE (OPENSTREAM TOFILE 'OUTPUT]
        (RESETSAVE (OUTPUT TOFILE))
        (LET ((ENV *DEFAULT-MAKEFILE-ENVIRONMENT*))
             (SETQ ENV (if ENV
                           then (\DO-DEFINE-FILE-INFO NIL ENV)
                         else *OLD-INTERLISP-READ-ENVIRONMENT*))
             (WITH-READER-ENVIRONMENT ENV
                 (PRINT-READER-ENVIRONMENT ENV)
                 (printout NIL "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T)
                        " ON "
                        (DATE)
                        "%"  T)" T "(LISPXTERPRI T)" T)
                 (for F inside FROMFILES do (MAPC (IMPORTFILE F (OR FLG T))
                                                              (FUNCTION PRINT))
                                                       (TERPRI))
                 (PRINT 'STOP)
                 (TERPRI)
                 (FULLNAME TOFILE))))])

(\DUMPEXPORTS
  [NLAMBDA COMS                                          (* bvm%: "24-Oct-86 19:42")

(* ;;; "Dumps an EXPORT form.  IMPORTFILE looks for a string announcing imports, but we must print it in a way that lets the file be loaded ok.")

    (PRIN1 "(")
    (PRIN2 '*)
    (PRIN1 (SUBSTRING BEGINEXPORTDEFSTRING 2))               (* ; 
                                   "BEGINEXPORTDEFSTRING starts with a * for benefit of IMPORTFILE")
    (for TAIL on COMS do (PRETTYCOM (CAR TAIL)))
    (TERPRI)
    (PRINT ENDEXPORTDEFFORM)
    (TERPRI])
)
(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (\DUMPEXPORTS . X])

(RPAQ? BEGINEXPORTDEFSTRING "* %"FOLLOWING DEFINITIONS EXPORTED%")")

(RPAQ? ENDEXPORTDEFFORM '(* "END EXPORTED DEFINITIONS"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS BEGINEXPORTDEFSTRING ENDEXPORTDEFFORM)
)



(* ; "for GAINSPACE")

(DEFINEQ

(CLEARFILEPKG
  [LAMBDA (FLG)                                          (* bvm%: "29-Aug-86 13:02")
    (PROG NIL
          (COND
             ((SELECTQ FLG
                  ((E T) 
                       T)
                  (Y (TERPRI T)
                     (PRIN1 "you can delete just the filemaps -
" T)
                     (PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? "
                                   '((Y "es - everything" RETURN T)
                                     (N "o - just the filemaps" RETURN NIL)
                                     (E "verything" RETURN T)
                                     (F "ilemaps only" RETURN NIL]
                            (TERPRI T)))
                  NIL)
              (UPDATEFILES)
              [SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE)
                                                        (COND
                                                           ((fetch TOBEDUMPED
                                                               of (fetch FILEPROP
                                                                         of FILE))
                                                            (PRINT FILE T T)
                                                            (PRIN1 " has changes, not wiped." T)
                                                            (TERPRI T)
                                                            T)
                                                           (T (replace FILEPROP of FILE
                                                                 with NIL)
                                                              (replace FILECHANGES of FILE
                                                                 with NIL)
                                                              (SMASHFILECOMS FILE)
                                                              (NCONC1 SYSFILES FILE)
                                                              NIL]
              (SETQ LOADEDFILELST)))
          (SELECTQ FLG
              ((NIL T))
              (CLRHASH *FILEMAP-HASH*])
)

(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
                                    ((Y "es")
                                     (N "o")
                                     (E . "verything")
                                     (F "ilemaps only%
-"))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS SMASHPROPSLST1)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS %#UNDOSAVES ADDTOFILEKEYLST CLEANUPOPTIONS CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST 
       DEFAULTRENAMEMETHOD FILEPKGCOMSPLST FILERDTBL HISTORYCOMS HISTSTR0 I.S.OPRLST LISPXCOMS 
       LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS MACROPROPS MAKEFILEOPTIONS MAKEFILEREMAKEFLG 
       MSDATABASELST PRETTYHEADER PRETTYTRANFLG SAVEDDEFS SYSPROPS USERMACROS USERRECLST USERWORDS 
       FILEPKGTYPEPROPS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
       (SPECVARS COMSNAME))

(BLOCK%: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
       (NOLINKFNS . T)
       (SPECVARS COMSNAME)
       (ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES? ADDTOCOM1))

(BLOCK%: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS 
       INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
       (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
       INFILECOMSPROP)

(BLOCK%: NIL MAKEFILE (LOCALVARS . T)
       (SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))

(BLOCK%: ADDFILE ADDFILE ADDFILE0)

(BLOCK%: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))

(BLOCK%: NIL ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE COMPAREDEFS 
       COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES EDITDEF 
       EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE
       FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES 
       MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS MARKASCHANGED 
       MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS PROPS.WHENCHANGED PUTDEF RENAME SAVEDEF 
       SAVEPUT SEARCHPRETTYTYPELST SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF 
       UPDATEFILES (GLOBALVARS %#UNDOSAVES SYSFILES MARKASCHANGEDSTATS COMPILE.EXT EDITMACROS 
                          EDITLOADFNSFLG LOADOPTIONS)
       (LOCALVARS . T))

(BLOCK%: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))

(BLOCK%: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE 
       GETDEFSAVED (RETFNS GETDEFCOM)
       (NOLINKFNS . T)
       (GLOBALVARS NOT-FOUNDTAG))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \DUMPEXPORTS MAKEUSERMACROSCOMS MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS 
                          MAKEALISTCOMS LISTFILES COMPILEFILES CLEANUP FILEPKGCOMPROPS 
                          PRETTYDEFMACROS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
(PUTPROPS FILEPKG COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1995 2018 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (22668 24373 (SEARCHPRETTYTYPELST 22678 . 23657) (PRETTYDEFMACROS 23659 . 24117) (
FILEPKGCOMPROPS 24119 . 24371)) (25175 59116 (CLEANUP 25185 . 26573) (COMPILEFILES 26575 . 26851) (
COMPILEFILES0 26853 . 27573) (CONTINUEDIT 27575 . 28995) (MAKEFILE 28997 . 40639) (FILECHANGES 40641
 . 42976) (FILEPKG.MERGECHANGES 42978 . 43801) (FILEPKG.CHANGEDFNS 43803 . 44115) (MAKEFILE1 44117 . 
48387) (COMPILE-FILE? 48389 . 49721) (MAKEFILES 49723 . 51416) (ADDFILE 51418 . 53939) (ADDFILE0 53941
 . 58077) (LISTFILES 58079 . 59114)) (59804 95044 (FILEPKGCHANGES 59814 . 61164) (GETFILEPKGTYPE 61166
 . 64239) (MARKASCHANGED 64241 . 65878) (FILECOMS 65880 . 66264) (WHEREIS 66266 . 67686) (
SMASHFILECOMS 67688 . 67923) (FILEFNSLST 67925 . 68087) (FILECOMSLST 68089 . 68573) (UPDATEFILES 68575
 . 73875) (INFILECOMS? 73877 . 75780) (INFILECOMTAIL 75782 . 76922) (INFILECOMS 76924 . 77085) (
INFILECOM 77087 . 87296) (INFILECOMSVALS 87298 . 87625) (INFILECOMSVAL 87627 . 88629) (INFILECOMSPROP 
88631 . 89460) (IFCPROPS 89462 . 90723) (IFCEXPRTYPE 90725 . 91236) (IFCPROPSCAN 91238 . 92291) (
IFCDECLARE 92293 . 93604) (INFILEPAIRS 93606 . 93938) (INFILECOMSMACRO 93940 . 95042)) (95079 125174 (
FILES? 95089 . 97282) (FILES?1 97284 . 97934) (FILES?PRINTLST 97936 . 98718) (ADDTOFILES? 98720 . 
108641) (ADDTOFILE 108643 . 109559) (WHATIS 109561 . 111537) (ADDTOCOMS 111539 . 113183) (ADDTOCOM 
113185 . 119732) (ADDTOCOM1 119734 . 120905) (ADDNEWCOM 120907 . 121957) (MAKENEWCOM 121959 . 123802) 
(DEFAULTMAKENEWCOM 123804 . 125172)) (125244 128061 (MERGEINSERT 125254 . 127597) (MERGEINSERT1 127599
 . 128059)) (129323 140235 (DELFROMFILES 129333 . 130183) (DELFROMCOMS 130185 . 131864) (DELFROMCOM 
131866 . 137734) (DELFROMCOM1 137736 . 138533) (REMOVEITEM 138535 . 139409) (MOVETOFILE 139411 . 
140233)) (140449 142818 (SAVEPUT 140459 . 142816)) (142943 151267 (UNMARKASCHANGED 142953 . 144661) (
PREEDITFN 144663 . 147174) (POSTEDITPROPS 147176 . 149677) (POSTEDITALISTS 149679 . 151265)) (151416 
171970 (ALISTS.GETDEF 151426 . 151805) (ALISTS.WHENCHANGED 151807 . 152451) (CLEARCLISPARRAY 152453 . 
153627) (EXPRESSIONS.WHENCHANGED 153629 . 154003) (MAKEALISTCOMS 154005 . 155078) (MAKEFILESCOMS 
155080 . 156517) (MAKELISPXMACROSCOMS 156519 . 158537) (MAKEPROPSCOMS 158539 . 159237) (
MAKEUSERMACROSCOMS 159239 . 161039) (PROPS.WHENCHANGED 161041 . 161662) (FILEGETDEF.LISPXMACROS 161664
 . 163106) (FILEGETDEF.ALISTS 163108 . 163727) (FILEGETDEF.RECORDS 163729 . 164660) (FILEGETDEF.PROPS 
164662 . 165454) (FILEGETDEF.MACROS 165456 . 166516) (FILEGETDEF.VARS 166518 . 166934) (FILEGETDEF.FNS
 166936 . 168300) (FILEPKGCOMS.PUTDEF 168302 . 170742) (FILES.PUTDEF 170744 . 171701) (VARS.PUTDEF 
171703 . 171846) (FILES.WHENCHANGED 171848 . 171968)) (173992 181425 (RENAME 174002 . 175403) (
CHANGECALLERS 175405 . 181423)) (181426 229374 (SHOWDEF 181436 . 182229) (COPYDEF 182231 . 184705) (
GETDEF 184707 . 186983) (GETDEFCOM 186985 . 187951) (GETDEFCOM0 187953 . 189299) (GETDEFCURRENT 189301
 . 195721) (GETDEFERR 195723 . 197024) (GETDEFFROMFILE 197026 . 201306) (GETDEFSAVED 201308 . 202412) 
(PUTDEF 202414 . 203117) (EDITDEF 203119 . 204096) (DEFAULT.EDITDEF 204098 . 206934) (EDITDEF.FILES 
206936 . 207137) (LOADDEF 207139 . 207315) (DWIMDEF 207317 . 208171) (DELDEF 208173 . 211187) (
DELFROMLIST 211189 . 211693) (HASDEF 211695 . 218017) (GETFILEDEF 218019 . 218541) (SAVEDEF 218543 . 
220202) (UNSAVEDEF 220204 . 221100) (COMPAREDEFS 221102 . 224404) (COMPARE 224406 . 225110) (TYPESOF 
225112 . 229372)) (229441 234484 (FIXEDITDATE 229451 . 232954) (EDITDATE? 232956 . 234482)) (234903 
243489 (FILEPKGCOM 234913 . 239846) (FILEPKGTYPE 239848 . 243487)) (255526 270078 (FINDCALLERS 255536
 . 256051) (EDITCALLERS 256053 . 263711) (EDITFROMFILE 263713 . 269393) (FINDATS 269395 . 269667) (
LOOKIN 269669 . 270076)) (270079 271806 (SEPRCASE 270089 . 271804)) (272323 277865 (IMPORTFILE 272333
 . 273307) (IMPORTEVAL 273309 . 274189) (IMPORTFILESCAN 274191 . 274612) (CHECKIMPORTS 274614 . 275950
) (GATHEREXPORTS 275952 . 277275) (\DUMPEXPORTS 277277 . 277863)) (278203 280411 (CLEARFILEPKG 278213
 . 280409)))))
STOP
\ No newline at end of file
diff --git a/sources/LLKEY.LCOM.~1~ b/sources/LLKEY.LCOM.~1~
deleted file mode 100644
index 96d6a036..00000000
--- a/sources/LLKEY.LCOM.~1~
+++ /dev/null
@@ -1,141 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 9-Apr-2000 16:32:15" ("compiled on " {DSK}<tilde>sybalsky>lispcore>sources>LLKEY.;7) 
"30-Jan-2000 16:38:25" "COMPILE-FILEd" in "Medley 31-Jan-20 ..." dated "31-Jan-2000 00:39:45")
(FILECREATED " 9-Apr-2000 16:28:23" {DSK}<tilde>sybalsky>lispcore>sources>LLKEY.;7 207701 changes to%:
 (FNS FLIPCURSORBAR FLIPCURSOR) previous date%: "30-Mar-2000 20:01:05" 
{DSK}<tilde>sybalsky>lispcore>sources>LLKEY.;6)
(RPAQQ LLKEYCOMS ((COMS (* ; "Access to keyboard") (FNS BKSYSCHARCODE \CLEARSYSBUF \GETKEY 
\NSYSBUFCHARS \SAVESYSBUF \SYSBUFP \GETSYSBUF \PUTSYSBUF \PEEKSYSBUF) (INITVARS (\LONGSYSBUF)) (
INITVARS (\\KEYBOARDWAITBOX.GLOBALRESOURCE)) (DECLARE%: DONTCOPY (RESOURCES \KEYBOARDWAITBOX)) (
DECLARE%: DONTCOPY (CONSTANTS (\SYSBUFSIZE 200)) (MACROS \GETREALSYSBUF))) (DECLARE%: DOCOPY 
DONTEVAL@LOAD (COMS (* ; "Here because it must be done in init before PROC loaded") (P (MOVD? (QUOTE 
NILL) (QUOTE CARET))))) (COMS (* ; "Key handler") (FNS \KEYBOARDINIT \KEYBOARDEVENTFN \ALLOCLOCKED 
\SETIOPOINTERS \KEYBOARDOFF \KEYBOARDON \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD \DOMOUSECHORDING 
\DOTRANSITIONS \DECODETRANSITION MOUSECHORDWAIT \TRACKCURSOR) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (
\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (INITVARS (\MOUSECHORDTICKS) (
\MOUSECHORDMILLISECONDS 50)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\KEYBOARDINIT))) (DECLARE%: DONTCOPY 
(MACROS .NOTELASTUSERACTION) (CONSTANTS ALLUP \CTRLMASK \METABIT) (CONSTANTS * DLMOUSEBITS) (CONSTANTS
 * DLMOUSESTATES) (CONSTANTS * TRANSITIONFLAGS) (MACROS \TRANSINDEX ARMEDCODE TRANSITIONALTGRCODE 
TRANSITIONSHIFTCODE TRANSITIONCODE TRANSITIONFLAGS TRANSITIONDEADLIST CHECKFORDEADKEY) (EXPORT (
RECORDS KEYACTION) (CONSTANTS \NKEYS)) (RECORDS RING) (COMS (* ; 
"can get rid of shiftstate after clients have been fixed") (RECORDS SHIFTSTATE) (GLOBALVARS 
\SHIFTSTATE \MOUSETIMERTEMP)) (CONSTANTS NRINGINDEXWORDS) (CONSTANTS (\SYSBUFFER.FIRST (UNFOLD 
NRINGINDEXWORDS BYTESPERWORD)) (\SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE))))) (
DECLARE%: EVAL@COMPILE (VARS \KEYNAMES)) (* ;; 
"\maikokeyactions does not contain keyactions of the form %"2,50%" because it breaks the loadup process on the sun."
) (VARS \ORIGKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DORADOKEYACTIONS \DOVEKEYACTIONS 
\DOVEOSDKEYACTIONS \MAIKOKEYACTIONS \MAIKOKEYACTIONST4 \MAIKO-JLE-KEYACTIONS \TOSHIBA-KEYACTIONS) (
VARS (KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS NIL)) (INITVARS (\KEYBOARD.META 256) (
\MODIFIED.KEYACTIONS)) (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS \RCLKSECOND \LASTUSERACTION 
\LASTKEYSTATE))) (GLOBALVARS \SYSBUFFER \LONGSYSBUF \INTERRUPTSTATE \MODIFIED.KEYACTIONS 
\MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING \CURRENTKEYACTION \COMMANDKEYACTION 
\DEFAULTKEYACTION \TIMER.INTERRUPT.PENDING \ORIGKEYACTIONS \KEYBOARD.META \MOUSECHORDMILLISECONDS 
\DORADOKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DOVEKEYACTIONS \DOVEOSDKEYACTIONS)) (COMS (* ;
 "Key interpretation") (FNS KEYACTION KEYACTIONTABLE KEYBOARDTYPE RESETKEYACTION 
\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS \KEYACTION1 KEYDOWNP KEYNUMBERP \KEYNAMETONUMBER 
MODIFY.KEYACTIONS METASHIFT SHIFTDOWNP) (* ; "To support office style 1108 & 1186 keyboards") (FNS 
SETUP.OFFICE.KEYBOARD) (OPTIMIZERS \KEYNAMETONUMBER) (MACROS \TEMPCOPYTIMER) (* ; 
"Don't copy this optimizer since it expands out to \getbasebit, but do exportit.") (DECLARE%: DONTCOPY
 (EXPORT (OPTIMIZERS KEYDOWNP))) (EXPORT (MACROS XKEYDOWNP KEYDOWNP1 \NEWKEYDOWNP))) (COMS (* ; 
"A raw keyboard device/stream") (FNS \INIT.KEYBOARD.STREAM) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (
\INIT.KEYBOARD.STREAM))) (EXPORT (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM))) (COMS (* ; 
"Hook for a periodic interrupt") (FNS \DOBUFFEREDTRANSITIONS \TIMER.INTERRUPTFRAME 
\PERIODIC.INTERRUPTFRAME) (INITVARS (\KEYBUFFERING) (\PERIODIC.INTERRUPT) (\TIMER.INTERRUPT.PENDING) (
\PERIODIC.INTERRUPT.FREQUENCY 77))) (LOCALVARS . T) (COMS (* ; "cursor and mouse related functions.") 
(FNS \HARDCURSORUP \HARDCURSORPOSITION \HARDCURSORDOWN) (FNS CURSOR.INIT \CURSORDESTINATION 
\SOFTCURSORUP \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN CURSORPROP GETCURSORPROP 
PUTCURSORPROP \CURSORBITSPERPIXEL \CURSORIMAGEPROPNAME \CURSORMASKPROPNAME) (FNS CURSORCREATE CURSOR 
\CURSOR-VALID-P \CURSORUP \CURSORPOSITION \CURSORDOWN ADJUSTCURSORPOSITION CURSORPOSITION CURSORSCREEN
 CURSOREXIT FLIPCURSOR FLIPCURSORBAR LASTMOUSEX LASTMOUSEY CREATEPOSITION POSITIONP CURSORHOTSPOT) (
PROPS (CURSORPROP ARGNAMES)) (INITVARS (\CURSORHOTSPOTX 0) (\CURSORHOTSPOTY 0) (\CURRENTCURSOR NIL) (
\SOFTCURSORWIDTH NIL) (\SOFTCURSORHEIGHT NIL) (\SOFTCURSORP NIL) (\SOFTCURSORUPP NIL) (\SOFTCURSORUPBM
 NIL) (\SOFTCURSORDOWNBM NIL) (\SOFTCURSORBBT1 NIL) (\SOFTCURSORBBT2 NIL) (\SOFTCURSORBBT3 NIL) (
\SOFTCURSORBBT4 NIL) (\SOFTCURSORBBT5 NIL) (\SOFTCURSORBBT6 NIL) (\CURSORSCREEN NIL) (
\CURSORDESTINATION NIL) (\CURSORDESTHEIGHT 808) (\CURSORDESTWIDTH 1024) (\CURSORDESTRASTERWIDTH 64) (
\CURSORDESTLINE 0) (\CURSORDESTLINEBASE NIL)) (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY 
\CURRENTCURSOR \SOFTCURSORWIDTH \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM 
\SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 
\SOFTCURSORBBT6 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH \CURSORDESTRASTERWIDTH 
\CURSORDESTLINE \CURSORDESTLINEBASE) (FNS GETMOUSESTATE \EVENTKEYS) (EXPORT (CONSTANTS (
HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS LASTMOUSEX 
LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD)))) (DECLARE%: DONTCOPY (EXPORT (
MACROS \SETMOUSEXY)) (MACROS \XMOUSECOORD \YMOUSECOORD)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD (
QUOTE CURSOR) (QUOTE SETCURSOR)) (MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION))) (VARS (
\SFPosition (CREATEPOSITION))))) (COMS (DECLARE%: DONTCOPY (RECORDS KEYBOARDEVENT) (CONSTANTS (
\KEYBOARDEVENT.FIRST NRINGINDEXWORDS) \KEYBOARDEVENT.SIZE (\KEYBOARDEVENT.LAST (PLUS 
\KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383)))))) (COMS (FNS MACHINETYPE SETMAINTPANEL) (* ; 
"DLion beeper") (FNS BEEPON BEEPOFF)) (EXPORT (GLOBALVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX 
\EM.CURSORY \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 
\EM.KBDAD5 \EM.DISPINTERRUPT \EM.DISPLAYHEAD \EM.CURSORBITMAP \MACHINETYPE \DEFAULTKEYACTION 
\COMMANDKEYACTION \CURRENTKEYACTION \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY)) (FNS 
WITHOUT-INTERRUPTS) (COMS (* ; "Compile locked fns together for locality") (BLOCKS (NIL FLIPCURSORBAR 
\KEYHANDLER \KEYHANDLER1 \TRACKCURSOR \PERIODIC.INTERRUPTFRAME \TIMER.INTERRUPTFRAME 
\DOBUFFEREDTRANSITIONS \DOTRANSITIONS \DECODETRANSITION \EVENTKEYS \HARDCURSORUP \DOMOUSECHORDING 
\KEYBOARDOFF \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP \SOFTCURSORUPCURRENT 
\SOFTCURSORPOSITION \SOFTCURSORDOWN))) (DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (ALLOCAL (ADDVARS (
LOCKEDFNS FLIPCURSORBAR \SETIOPOINTERS \KEYHANDLER \KEYHANDLER1 \CONTEXTAPPLY \LOCKPAGES 
\DECODETRANSITION \SMASHLINK \INCUSECOUNT LLSH \MAKEFREEBLOCK \DECUSECOUNT \MAKENUMBER \ADDBASE 
\PERIODIC.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS \TIMER.INTERRUPTFRAME \CAUSEINTERRUPT \DOMOUSECHORDING
 \KEYBOARDOFF \TRACKCURSOR \HARDCURSORUP \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP 
\SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN \SOFTCURSORPILOTBITBLT) (LOCKEDVARS 
\InterfacePage \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH \SOFTCURSORHEIGHT 
\SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2 
\SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 \CURSORDESTINATION \CURSORDESTHEIGHT 
\CURSORDESTWIDTH \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE \PENDINGINTERRUPT 
\PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY \LASTUSERACTION \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE
 \KEYBUFFERING SCREENWIDTH SCREENHEIGHT \TIMER.INTERRUPT.PENDING \EM.MOUSEX \EM.MOUSEY \EM.CURSORX 
\EM.CURSORY \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.DISPINTERRUPT 
\EM.CURSORBITMAP \EM.KBDAD4 \EM.KBDAD5 \MISCSTATS \RCLKSECOND)))) (RDCOMS (FNS \SETIOPOINTERS)))) (
PROP FILETYPE LLKEY) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (
NLAML WITHOUT-INTERRUPTS) (LAMA CURSORPROP METASHIFT MOUSECHORDWAIT)))))
BKSYSCHARCODE :D8
(L (0 CHAR)) s@	�[`P`�\j�5`L��`�`Ldl��l�k�[��K�`j���H
-@	�I�	JhY���J&���(96 \PUTSYSBUF 85 \NCONC2 5 \PUTSYSBUF)
(90 \LONGSYSBUF 72 \SYSBUFFER 48 \SYSBUFFER 41 \SYSBUFFER 32 \SYSBUFFER 20 \SYSBUFFER 12 \LONGSYSBUF)
()
\CLEARSYSBUF :D8
(L (0 ALLFLG)) L@�`d�`�h�`j��@�`�dh&���h`d�h&hNIL
(69 PROCESS 62 \RUNNING.PROCESS 47 PROCESS 39 \PROCESSES 27 \SYSBUFFER 21 \LONGSYSBUF 13 \TTY.PROCESS 6 \RUNNING.PROCESS)
()
\GETKEY :D8
NIL �`�N�h`�2lH	�h�Y�K`l�H	��IH�h����&��`H�&YHI&����(132 \WAIT.FOR.TTY 126 \TTYBACKGROUND 62 CLOCKDIFFERENCE 45 \GETSYSBUF 37 \CLOCK0 16 \GETSYSBUF 11 WAIT.FOR.TTY)
(115 PROCESS 105 PROCESS 96 \RUNNING.PROCESS 87 PROCESS 79 \\KEYBOARDWAITBOX.GLOBALRESOURCE 71 \\KEYBOARDWAITBOX.GLOBALRESOURCE 53 \MISCSTATS 23 \\KEYBOARDWAITBOX.GLOBALRESOURCE 4 \RUNNING.PROCESS)
()
\NSYSBUFCHARS :D8
NIL 1`	`�`�Hj�j�IdH�H�Hl����(9 LENGTH)
(21 \SYSBUFFER 14 \SYSBUFFER 4 \LONGSYSBUF)
()
\SAVESYSBUF :D8
NIL �`jC`�``�z`�IH	�PI	��G�&[��`h&�IK	�YH	�I	�K�d�HJk�ZL���IJkؾ�NM�HN�Nkٹ��Ij�h�
-HkI�Nk�^��(174 RPLCHARCODE 168 SUBSTRING 145 \GETSYSBUF 123 RPLCHARCODE 106 ALLOCSTRING 98 NCHARS 90 LENGTH 56 ALLOCSTRING 47 NCHARS 9 \NSYSBUFCHARS)
(79 PROCESS 74 \RUNNING.PROCESS 64 PROCESS 38 \RUNNING.PROCESS 30 \TTY.PROCESS 25 \RUNNING.PROCESS 18 \RUNNING.PROCESS 4 \SAVEDSYSBUFFER)
()
\SYSBUFP :D8
NIL >`�`d`��`�"`�j�h�`�`�&NIL
(57 PROCESS 52 \RUNNING.PROCESS 45 \RUNNING.PROCESS 32 \SYSBUFFER 25 \LONGSYSBUF 16 \TTY.PROCESS 10 \RUNNING.PROCESS 4 \RUNNING.PROCESS)
()
\GETSYSBUF :D8
NIL _`�``��D`�Hj�h�3`H��`�`Hdl��l�k�Y��I�`j��NIL
(88 \SYSBUFFER 64 \SYSBUFFER 57 \SYSBUFFER 48 \SYSBUFFER 31 \SYSBUFFER 23 \LONGSYSBUF 17 \LONGSYSBUF 11 \LONGSYSBUF 4 \LONGSYSBUF)
()
\PUTSYSBUF :D8
(L (0 CHAR)) D`�`�HI�h`I�@�Hj�`I��`Idl��l�k��iNIL
(50 \SYSBUFFER 41 \SYSBUFFER 27 \SYSBUFFER 11 \SYSBUFFER 4 \SYSBUFFER)
()
\PEEKSYSBUF :D8
(L (0 STREAM)) \�6`�`d`�*�`�`�Xj��`H������`�&(89 SHOULDNT 66 BLOCK 7 \SYSBUFP)
(80 PROCESS 75 \RUNNING.PROCESS 54 \SYSBUFFER 42 \SYSBUFFER 35 \LONGSYSBUF 26 \TTY.PROCESS 20 \RUNNING.PROCESS 14 \RUNNING.PROCESS)
()
(RPAQ? \LONGSYSBUF)
(RPAQ? \\KEYBOARDWAITBOX.GLOBALRESOURCE)
(MOVD? (QUOTE NILL) (QUOTE CARET))
\KEYBOARDINIT :D8
NIL  l	l�k�k��	j��`l�l�hdi`l8�n�l�k��	j��`l�lk��	Hn����Hn����Hn����Hn����Hn����Hn����Hn����Hlj�Hj�	�H`�l��j�k�j�	P�Hj�	пHld���	lwj�`	(285 \KEYBOARDON 280 MOUSECHORDWAIT 249 \ALLOCBLOCK 197 \PUTBASEFIXP 136 \ALLOCBLOCK 108 \ALLOCLOCKED 76 ALLOCSTRING 48 \ALLOCBLOCK 31 \ALLOCLOCKED 19 KEYACTIONTABLE 4 KEYACTIONTABLE)
(275 \MOUSECHORDMILLISECONDS 270 \MOUSETIMERTEMP 262 FIXP 254 \SHIFTSTATE 238 \LASTKEYSTATE 210 \EM.KBDAD3 122 \KEYBOARDEVENTQUEUE 113 \KEYBOARDEVENTQUEUE 94 \LASTUSERACTION 86 \MISCSTATS 81 \SAVEDSYSBUFFER 62 \SYSBUFFER 53 \SYSBUFFER 36 \INTERRUPTSTATE 24 \COMMANDKEYACTION 14 \CURRENTKEYACTION 9 \DEFAULTKEYACTION)
()
\KEYBOARDEVENTFN :D8
(L (2 EXTRA 1 EVENT 0 FDEV) F 1 \MAIKO.XBEFORE?) �Ag�Ag�Ag�Adg�<�``�!l�g�o	o�cg� Ag�Ag�Ag���``�%Qg�o	o���g�2�&dHH`�HH`�۰:`
-�&dHH`�HH`��	g�V``�!l��E`
-�&dHH`�HH`��	h(404 MOUSECHORDWAIT 399 MOUSECHORDWAIT 389 KEYACTION 374 KEYACTION 353 \APPEND2 348 \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS 312 MACHINETYPE 306 MOUSECHORDWAIT 301 MOUSECHORDWAIT 291 KEYACTION 276 KEYACTION 255 \APPEND2 250 \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS 233 KEYACTION 218 KEYACTION 197 \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS 184 MACHINETYPE 168 UNIX-GETPARM 150 MACHINETYPE 84 UNIX-GETPARM 66 MACHINETYPE)
(384 \DEFAULTKEYACTION 369 \COMMANDKEYACTION 343 \ORIGKEYACTIONS 330 \InterfacePage 325 \MAIKO.BEFOREKEYTYPE 317 MAIKO 286 \DEFAULTKEYACTION 271 \COMMANDKEYACTION 245 \ORIGKEYACTIONS 228 \DEFAULTKEYACTION 213 \COMMANDKEYACTION 189 MAIKO 155 MAIKO 141 \KEYBOARD.BEFORETYPE 136 \MACHINETYPE 124 AFTERSAVEVM 116 AFTERSYSOUT 107 AFTERMAKESYS 98 AFTERLOGOUT 71 MAIKO 61 \MAIKO.BEFOREKEYTYPE 51 \InterfacePage 46 \KEYBOARD.BEFORETYPE 41 \MACHINETYPE 32 BEFORESAVEVM 23 BEFORESYSOUT 14 BEFOREMAKESYS 5 BEFORELOGOUT)
( 173 "X" 163 "DISPLAY" 89 "X" 79 "DISPLAY")
\ALLOCLOCKED :D8
(L (0 NCELLS)) (@h@dl��l�Hd�l��@��l���
-H(36 \LOCKCELL 15 \ALLOCBLOCK)
NIL
()
\SETIOPOINTERS :D8
NIL ig`�
-dl�dl��go
-�go
-�go
-�go
-�go�
-�go�
-�go�
-�go�
-�go�
-�g`lB�
-�`n����g`lC�
-�`n����go
-�go
-�go
-�g`�����
-�$dl�dl�$�g`l;�
-�g`l<�
-�g`l��
-�g`l��
-�g`l=�
-�g`l>�
-�g`l?�
-�g`l@�
-�g`lA�
-�g`lB�
-�g`lC�
-�g`l��
-�g`l��
-�gh
-�g`l�}C�n
-��l��gHk�
-�gHl�
-�gHl�
-�gHl�
-�gHl�
-�gHl�
-�g
-�g
-�g
-�g`l��
-�g`l��
-�g`l��
-�gH
-�g
-��g`l<�
-(870 SETTOPVAL 851 RAID 844 SETTOPVAL 839 \DoveDisplay.ScreenWidth 828 SETTOPVAL 816 SETTOPVAL 797 SETTOPVAL 778 SETTOPVAL 759 SETTOPVAL 754 \DoveDisplay.GetCursorBitmapBase 743 SETTOPVAL 738 \DoveMisc.GetMouseYBase 727 SETTOPVAL 722 \DoveMisc.GetMouseXBase 711 SETTOPVAL 696 SETTOPVAL 681 SETTOPVAL 666 SETTOPVAL 651 SETTOPVAL 636 SETTOPVAL 620 \DoveMisc.GetKBDBase 605 SETTOPVAL 578 SETTOPVAL 566 SETTOPVAL 547 SETTOPVAL 528 SETTOPVAL 509 SETTOPVAL 490 SETTOPVAL 471 SETTOPVAL 452 SETTOPVAL 433 SETTOPVAL 414 SETTOPVAL 395 SETTOPVAL 376 SETTOPVAL 357 SETTOPVAL 338 SETTOPVAL 303 SETTOPVAL 281 SETTOPVAL 265 SETTOPVAL 249 SETTOPVAL 222 SETTOPVAL 192 SETTOPVAL 173 SETTOPVAL 157 SETTOPVAL 141 SETTOPVAL 125 SETTOPVAL 109 SETTOPVAL 93 SETTOPVAL 77 SETTOPVAL 61 SETTOPVAL 45 SETTOPVAL 16 SETTOPVAL)
(862 \InterfacePage 857 \EM.UTILIN 834 SCREENWIDTH 822 \EM.REALUTILIN 808 \IOPAGE 803 \EM.CURSORY 789 \IOPAGE 784 \EM.CURSORX 770 \IOPAGE 765 \EM.DISPINTERRUPT 749 \EM.CURSORBITMAP 733 \EM.MOUSEY 717 \EM.MOUSEX 702 \EM.KBDAD5 687 \EM.KBDAD4 672 \EM.KBDAD3 657 \EM.KBDAD2 642 \EM.KBDAD1 628 \EM.KBDAD0 589 \MACHINETYPE 584 SCREENWIDTH 572 \EM.DISPLAYHEAD 558 \IOPAGE 553 \EM.CURSORBITMAP 539 \IOPAGE 534 \EM.DISPINTERRUPT 520 \IOPAGE 515 \EM.KBDAD5 501 \IOPAGE 496 \EM.KBDAD4 482 \IOPAGE 477 \EM.KBDAD3 463 \IOPAGE 458 \EM.KBDAD2 444 \IOPAGE 439 \EM.KBDAD1 425 \IOPAGE 420 \EM.KBDAD0 406 \IOPAGE 401 \EM.REALUTILIN 387 \IOPAGE 382 \EM.CURSORY 368 \IOPAGE 363 \EM.CURSORX 349 \IOPAGE 344 \EM.MOUSEY 330 \IOPAGE 325 \EM.MOUSEX 292 \InterfacePage 287 SCREENWIDTH 271 \EM.DISPLAYHEAD 255 \EM.CURSORBITMAP 239 \EM.DISPINTERRUPT 228 \EM.KBDAD5 214 \InterfacePage 209 \EM.KBDAD5 198 \EM.KBDAD4 184 \InterfacePage 179 \EM.KBDAD4 163 \EM.KBDAD3 147 \EM.KBDAD2 131 \EM.KBDAD1 115 \EM.KBDAD0 99 \EM.REALUTILIN 83 \EM.CURSORY 67 \EM.CURSORX 51 \EM.MOUSEY 35 \EM.MOUSEX 9 \InterfacePage 4 \MACHINETYPE)
()
\KEYBOARDOFF :D8
NIL `d�n����`l�h}RNIL
(18 \MACHINETYPE 4 \EM.DISPINTERRUPT)
()
\KEYBOARDON :D8
(L (0 NOCHECK)) #`d�n ��`l�i}R(4 \SETIOPOINTERS)
(23 \MACHINETYPE 9 \EM.DISPINTERRUPT)
()
\KEYHANDLER :D8
NIL (4 \KEYHANDLER1)
NIL
()
\KEYHANDLER1 :D8
NIL �n��dddddddl
-l<j`l:�`l<�=h�`j��l~�`�%Oj�O�lg
-�`�kk�_�`�O�`�O�`�_`�_
-�N`��Ok�/OwO�j�%l_�`�^O
-_�O`��EH`��:I`��/J`��$K`��L`��M`���`�nB�j�)`d�`d������`�Z���`�`�O"O ��`O �_$l�w�O$`�X��O$`�Y��O$`�Z��O$`�[��O$`�\��O$`�]��O$`�_��O"j�`O ��`n�O �l�O l���`�i�`�&`i�8lg
-�*g��`�lg
-�h�`l���Ok�_j���`l"�w`l ��_�`O�jO�+`l �`��`l�n���`l�k��k�l_���(573 \CAUSEINTERRUPT 539 \CAUSEINTERRUPT 313 \KEYBOARDOFF 189 \DOMOUSECHORDING 141 \TRACKCURSOR 81 \CAUSEINTERRUPT)
(674 \MISCSTATS 661 \MISCSTATS 654 \RCLKSECOND 646 \MISCSTATS 631 \RCLKSECOND 619 \MISCSTATS 610 \MISCSTATS 586 \MACHINETYPE 580 \PENDINGINTERRUPT 568 \INTERRUPTFRAME 559 \PENDINGINTERRUPT 551 \KEYBUFFERING 546 STARTED 534 \DOBUFFEREDTRANSITIONS 523 \KEYBUFFERING 516 \KEYBUFFERING 510 \KEYBUFFERING 502 \KEYBUFFERING 478 \KEYBOARDEVENTQUEUE 468 \KEYBOARDEVENTQUEUE 451 \EM.UTILIN 438 \EM.KBDAD5 425 \EM.KBDAD4 412 \EM.KBDAD3 399 \EM.KBDAD2 386 \EM.KBDAD1 373 \EM.KBDAD0 356 \KEYBOARDEVENTQUEUE 337 \KEYBOARDEVENTQUEUE 330 \KEYBOARDEVENTQUEUE 319 \EM.KBDAD2 299 \InterfacePage 291 \InterfacePage 276 \EM.KBDAD2 264 \EM.KBDAD5 254 \EM.KBDAD4 243 \EM.KBDAD3 232 \EM.KBDAD2 221 \EM.KBDAD1 210 \EM.KBDAD0 199 \EM.UTILIN 179 \EM.REALUTILIN 148 \EM.REALUTILIN 132 \EM.MOUSEY 123 \EM.MOUSEX 111 \EM.MOUSEY 100 \EM.MOUSEX 87 \PERIODIC.INTERRUPT.FREQUENCY 76 \PERIODIC.INTERRUPTFRAME 58 \PERIODIC.INTERRUPT 45 \KEYBOARDEVENTQUEUE 39 \KEYBUFFERING 27 \MISCSTATS 19 \MISCSTATS)
()
\RESETKEYBOARD :D8
NIL Bh`l�`l�`l�`n����``���``���``���``���``���``���``���``�l��j�k�jHI�	P�I�`j�	0�`j�	@�`j�	`�`j�	p�`j�	��`j�	��`j�	��`j�	��`j�	h`j�`j�h`	(319 \KEYBOARDON 314 \DAYTIME0 4 \SETIOPOINTERS)
(309 \LASTUSERACTION 304 \LONGSYSBUF 295 \SYSBUFFER 287 \KEYBOARDEVENTQUEUE 282 \TIMER.INTERRUPT.PENDING 272 \LASTKEYSTATE 262 \LASTKEYSTATE 252 \LASTKEYSTATE 242 \LASTKEYSTATE 232 \LASTKEYSTATE 222 \LASTKEYSTATE 212 \LASTKEYSTATE 202 \LASTKEYSTATE 192 \LASTKEYSTATE 164 \EM.KBDAD3 159 \LASTKEYSTATE 149 \EM.REALUTILIN 144 \LASTKEYSTATE 134 \EM.KBDAD5 129 \LASTKEYSTATE 119 \EM.KBDAD4 114 \LASTKEYSTATE 104 \EM.KBDAD3 99 \LASTKEYSTATE 89 \EM.KBDAD2 84 \LASTKEYSTATE 74 \EM.KBDAD1 69 \LASTKEYSTATE 59 \EM.KBDAD0 54 \LASTKEYSTATE 43 \EM.UTILIN 34 \MACHINETYPE 25 \MACHINETYPE 15 \MACHINETYPE 10 \KEYBUFFERING)
()
\DOMOUSECHORDING :D8
(L (1 STATE 0 REALUTILIN)) �`�@l�l�Xj�jb���Aj�Adk�9�@l�b�Hl�@n���b�lb��aAk�\`l:�w`��kb��Fl�'@l�n���b�Hdl�lb��(l�#lb��Adl�@l�l�@l�n���b�`@�ANIL
(164 \EM.UTILIN 83 \MOUSECHORDTICKS 74 \MISCSTATS 7 \MOUSECHORDTICKS)
()
\DOTRANSITIONS :D8
(L (2 NEW 1 OLD 0 KEYBASE)) 1ljn�IH�iJdAB��j�I@�BJ�j�
-�J�Ik�Y��(37 \DECODETRANSITION)
NIL
()
\DECODETRANSITION :D8
(L (1 DOWNFLG 0 KEYNUMBER) F 4 PENDINGINTERRUPT) b``l$�l�A�lp@؀@`"`�H�dj�odl�!�I�	0j�I�	@j�I�	Pj�ti[�pdl��I�	0j�I�	@j�Wi[�Sdk�&dl	�Ij�	0hdl�Ik�	0hdl
-�Ij�	@hdl�Ik�	@hdl�Ij�	Phdl�Ik�	Phdl�Id�	Pj��k��dl�Ij�	`hdl�Ik�	`hdl�Ij�	phdl
�Ik�	phdl�Ij�	�hdl�Ik�	�hdl�Id�	�j��k��dl�Ij�	�hdl�Ik�	�hdl�Id�	�j��k��dl�Ij�	�hdl�Ik�	�hdl�Id�	�j��k��dl�Ij�	�hdl�Ik�	�hl�Id�	�j��k���K�`��`�H��ZI�	`j�I�	pj�I�	�j�LJl�K�`��`�H���Id�	`j�Jl��I�	pj�I�	�j�`J�J`�Z�J`��ic�`k�p�`J��J	h(606 \PUTSYSBUF 447 SHOULDNT)
(596 \INTERRUPTSTATE 586 \INTERRUPTSTATE 572 \CURRENTKEYACTION 563 \KEYBOARD.META 554 \KEYBOARD.META 513 \COMMANDKEYACTION 505 \COMMANDKEYACTION 463 \CURRENTKEYACTION 455 \CURRENTKEYACTION 36 \CURRENTKEYACTION 28 \LASTKEYSTATE 9 \MISCSTATS 4 \LASTUSERACTION)
()
MOUSECHORDWAIT :D8
(L (0 MSECS)) Ce`�`Hj�.ka�$ka�l2`�n��I�I�n���NIL
(63 \MOUSECHORDTICKS 42 \RCLKMILLISECOND 37 \MOUSECHORDMILLISECONDS 15 \MOUSECHORDMILLISECONDS 8 \MOUSECHORDTICKS)
()
\TRACKCURSOR :D8
(L (1 CURSORY 0 CURSORX)) |``l$�l�@``���D@n��-j@n���k�`��.`l�j�j`�n���b�``�k�b�h�A`l����A``���KAn��4jAn���k�`��3`l�`l�j�j`�n���``�k�b�`l�v`dl�@A
-�Odl�@A}A�Bl�>`@�)�`A�*�n�`���`@�)�`A�*�`n���`@��`A��`�@A
-�`l�@A
-�`@�`A�A(359 \DoveDisplay.SetCursorPosition 342 \SOFTCURSORPOSITION 231 \DoveMisc.SetMousePosition)
(373 \EM.CURSORY 365 \EM.CURSORX 348 \MACHINETYPE 334 \SOFTCURSORUPP 325 \EM.MOUSEY 316 \EM.MOUSEX 305 \IOPAGE 296 \IOPAGE 287 \IOPAGE 277 \IOPAGE 265 \IOPAGE 256 \IOPAGE 218 \MACHINETYPE 208 \MACHINETYPE 197 \CURSORHOTSPOTY 192 \CURSORDESTHEIGHT 181 \CURSORHOTSPOTY 168 \MACHINETYPE 159 \MACHINETYPE 150 \CURSORHOTSPOTY 125 \CURSORHOTSPOTY 120 \CURSORDESTHEIGHT 105 \CURSORDESTHEIGHT 91 \CURSORHOTSPOTX 86 \CURSORDESTWIDTH 72 \CURSORHOTSPOTX 60 \MACHINETYPE 51 \CURSORHOTSPOTX 26 \CURSORHOTSPOTX 21 \CURSORDESTWIDTH 9 \MISCSTATS 4 \LASTUSERACTION)
()
(RPAQQ \SUN.TYPE3KEYBOARD 0)
(RPAQQ \SUN.TYPE4KEYBOARD 1)
(RPAQQ \SUN.JLEKEYBOARD 2)
(RPAQQ \TOSHIBA.JIS 7)
(CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7))
(RPAQ? \MOUSECHORDTICKS)
(RPAQ? \MOUSECHORDMILLISECONDS 50)
(\KEYBOARDINIT)
(RPAQQ \KEYNAMES ((5 %% FIVE) (4 $ FOUR) (6 ~ SIX) (e E) (7 & SEVEN) (d D) (u U) (v V) (0 %) ZERO) (k 
K) (- %) (p P) (/ ?) (\ %| FONT LOOKS) (LF SAME) (BS <-) (3 %# THREE) (2 @ TWO) (w W) (q Q) (s S) (a 
A) (9 %( NINE) (i I) (x X) (o O) (l L) (%, <) (%' %") (%] }) (BLANK-MIDDLE OPEN DBK-HELP) (BLANK-TOP 
KEYBOARD DBK-META) (1 ! ONE) (ESC ESCAPE ->) (TAB =>) (f F) (CTRL PROP'S EDIT) (c C) (j J) (b B) (z Z)
 (LSHIFT) (%. >) (; %:) (CR <-%|) (_ ^) (DEL DELETE) (SKIP NEXT) (r R) (t T) (g G) (y Y) (h H) (8 * 
EIGHT) (n N) (m M) (LOCK) (SPACE) (%[ {) (= +) (RSHIFT) (BLANK-BOTTOM STOP) (MOVE) (UNDO) (UTIL0 
SUN-KEYPAD=) (UTIL1 SUN-KEYPAD/) (UTIL2 SUPER/SUB) (UTIL3 CASE) (UTIL4 STRIKEOUT) (UTIL5 KEYPAD2) (
UTIL6 KEYPAD3 PGDN) (UTIL7 SUN-LF) (PAD1 LEFTKEY CAPSLOCK KEYPAD+) (PAD2 LEFTMIDDLEKEY NUMLOCK KEYPAD-
) (PAD3 MIDDLEKEY SCROLLLOCK KEYPAD*) (PAD4 RIGHTMIDDLEKEY BREAK KEYPAD/ SUN-PAUSE) (PAD5 RIGHTKEY 
DOIT PRTSC) (LEFT RED MOUSERED) (RIGHT BLUE MOUSEBLUE) (MIDDLE YELLOW MOUSEYELLOW) (MARGINS) (K41 
KEYPAD7 HOME) (K42 KEYPAD8) (K43 KEYPAD9 PGUP) (K44 KEYPAD4) (K45 KEYPAD5) (K46 SUN-LEFT-SPACE) (K47 
KEYPAD6) (K48 SUN-RIGHT-SPACE) (COPY) (FIND) (AGAIN) (HELP) (DEF'N EXPAND) (K4E KEYPAD1 END) (
ALWAYS-ON-1) (ALWAYS-ON-2) (CENTER) (K52 KEYPAD0 INS) (BOLD) (ITALICS) (UNDERLINE) (SUPERSCRIPT) (
SUBSCRIPT) (LARGER SMALLER) (K59 KEYPAD%| KEYPAD.) (K5A KEYPAD\ KEYPAD, SUN-F10) (K5B SUN-F11) (K5C 
SUN-F12) (DEFAULTS SUN-PROP) (K5E SUN-PRTSC) (K5F SUN-OPEN)))
(RPAQQ \ORIGKEYACTIONS ((0 (53 "%%" NOLOCKSHIFT)) (1 (52 "$" NOLOCKSHIFT)) (2 (54 "~" NOLOCKSHIFT)) (3
 ("e" "E" LOCKSHIFT)) (4 (55 "&" NOLOCKSHIFT)) (5 ("d" "D" LOCKSHIFT)) (6 ("u" "U" LOCKSHIFT)) (7 ("v"
 "V" LOCKSHIFT)) (8 (48 ")" NOLOCKSHIFT)) (9 ("k" "K" LOCKSHIFT)) (10 ("-" "-" NOLOCKSHIFT)) (11 ("p" 
"P" LOCKSHIFT)) (12 ("/" "?" NOLOCKSHIFT)) (13 ("\" "|" NOLOCKSHIFT)) (14 (10 96 NOLOCKSHIFT)) (15 (8 
8 NOLOCKSHIFT)) (16 (51 "#" NOLOCKSHIFT)) (17 (50 "@" NOLOCKSHIFT)) (18 ("w" "W" LOCKSHIFT)) (19 ("q" 
"Q" LOCKSHIFT)) (20 ("s" "S" LOCKSHIFT)) (21 ("a" "A" LOCKSHIFT)) (22 (57 "(" NOLOCKSHIFT)) (23 ("i" 
"I" LOCKSHIFT)) (24 ("x" "X" LOCKSHIFT)) (25 ("o" "O" LOCKSHIFT)) (26 ("l" "L" LOCKSHIFT)) (27 ("," 
"<" NOLOCKSHIFT)) (28 ("'" "%"" NOLOCKSHIFT)) (29 ("]" "}" NOLOCKSHIFT)) (30 (194 194 NOLOCKSHIFT)) (
31 (193 193 NOLOCKSHIFT)) (32 (49 "!" NOLOCKSHIFT)) (33 (27 27 NOLOCKSHIFT)) (34 (9 9 NOLOCKSHIFT)) (
35 ("f" "F" LOCKSHIFT)) (36 CTRLDOWN . CTRLUP) (37 ("c" "C" LOCKSHIFT)) (38 ("j" "J" LOCKSHIFT)) (39 (
"b" "B" LOCKSHIFT)) (40 ("z" "Z" LOCKSHIFT)) (41 1SHIFTDOWN . 1SHIFTUP) (42 ("." ">" NOLOCKSHIFT)) (43
 (";" ":" NOLOCKSHIFT)) (44 (13 13 NOLOCKSHIFT)) (45 ("_" "^" NOLOCKSHIFT)) (46 (127 535 NOLOCKSHIFT))
 (47 ("(" "[" NOLOCKSHIFT)) (48 ("r" "R" LOCKSHIFT)) (49 ("t" "T" LOCKSHIFT)) (50 ("g" "G" LOCKSHIFT))
 (51 ("y" "Y" LOCKSHIFT)) (52 ("h" "H" LOCKSHIFT)) (53 (56 "*" NOLOCKSHIFT)) (54 ("n" "N" LOCKSHIFT)) 
(55 ("m" "M" LOCKSHIFT)) (56 LOCKDOWN . LOCKUP) (57 (32 32 NOLOCKSHIFT)) (58 ("[" "{" NOLOCKSHIFT)) (
59 ("=" "+" NOLOCKSHIFT)) (60 2SHIFTDOWN . 2SHIFTUP) (61 (195 195 NOLOCKSHIFT)) (63 (")" "]" 
NOLOCKSHIFT)) (77 EVENT . EVENT) (78 EVENT . EVENT) (79 EVENT . EVENT) (102 LOCKDOWN) (103 LOCKUP)))
(RPAQQ \DLIONKEYACTIONS ((2 (54 "^" NOLOCKSHIFT)) (10 ("-" "_" NOLOCKSHIFT)) (33 ("\" "|" NOLOCKSHIFT)
) (45 (96 "~" NOLOCKSHIFT)) (OPEN METADOWN . METAUP) (PROP'S CTRLDOWN . CTRLUP) (SAME METADOWN . 
METAUP) (FIND ("2,3" "2,43" NOLOCKSHIFT)) (UNDO ("2,4" "2,44" NOLOCKSHIFT)) (STOP (5 7 NOLOCKSHIFT)) (
MOVE) (COPY) (AGAIN ("2,10" "2,50" NOLOCKSHIFT)) (CENTER ("2,101" "2,141" NOLOCKSHIFT)) (BOLD ("2,102"
 "2,142" NOLOCKSHIFT)) (ITALICS ("2,103" "2,143" NOLOCKSHIFT)) (UNDERLINE ("2,106" "2,146" NOLOCKSHIFT
)) (SUPERSCRIPT ("2,113" "2,153" NOLOCKSHIFT)) (SUBSCRIPT ("2,114" "2,154" NOLOCKSHIFT)) (LARGER (
"2,110" "2,150" NOLOCKSHIFT)) (DEFAULTS ("2,115" "2,155" NOLOCKSHIFT)) (93 (27 "2,64" NOLOCKSHIFT)) (
47 ("2,22" "2,62" NOLOCKSHIFT)) (31 ("2,5" "2,45" NOLOCKSHIFT)) (92 ("2,1" "2,41" NOLOCKSHIFT)) (80 (
"2,13" "2,53" NOLOCKSHIFT)) (FONT ("2,112" "2,152" NOLOCKSHIFT))))
(RPAQQ \DLIONOSDKEYACTIONS ((56 LOCKTOGGLE)))
(RPAQQ \DORADOKEYACTIONS ((2 (54 "~" NOLOCKSHIFT)) (10 ("-" "-" NOLOCKSHIFT)) (13 ("\" "|" NOLOCKSHIFT
)) (14 (10 96 NOLOCKSHIFT)) (33 (27 27 NOLOCKSHIFT)) (45 ("_" "^" NOLOCKSHIFT))))
(RPAQQ \DOVEKEYACTIONS ((2 (54 "^" NOLOCKSHIFT)) (10 ("-" "_" NOLOCKSHIFT)) (33 (27 27 NOLOCKSHIFT)) (
56 CTRLDOWN . CTRLUP) (65 (27 27 NOLOCKSHIFT)) (71 (39 34 NOLOCKSHIFT)) (93 ("2,24" "2,64" NOLOCKSHIFT
)) (108 (96 126 NOLOCKSHIFT)) (DBK-META METADOWN . METAUP) (DBK-HELP ("2,1" "2,41" NOLOCKSHIFT)) (SAME
 METADOWN . METAUP) (FIND ("2,3" "2,43" NOLOCKSHIFT)) (UNDO ("2,4" "2,44" NOLOCKSHIFT)) (STOP (5 7 
NOLOCKSHIFT)) (EDIT ("2,5" "2,45" NOLOCKSHIFT)) (MOVE) (COPY) (AGAIN ("2,10" "2,50" NOLOCKSHIFT)) (
CENTER ("2,101" "2,141" NOLOCKSHIFT)) (BOLD ("2,102" "2,142" NOLOCKSHIFT)) (ITALICS ("2,103" "2,143" 
NOLOCKSHIFT)) (CASE ("2,104" "2,144" NOLOCKSHIFT)) (STRIKEOUT ("2,105" "2,145" NOLOCKSHIFT)) (
UNDERLINE ("2,106" "2,146" NOLOCKSHIFT)) (SUPER/SUB ("2,107" "2,147" NOLOCKSHIFT)) (LARGER ("2,110" 
"2,150" NOLOCKSHIFT)) (MARGINS ("2,111" "2,151" NOLOCKSHIFT)) (LOOKS ("2,112" "2,152" NOLOCKSHIFT)) (
CAPSLOCK LOCKTOGGLE) (NUMLOCK ("2,11" "-" NOLOCKSHIFT)) (SCROLLLOCK ("2,12" 180 NOLOCKSHIFT)) (BREAK (
2 184 NOLOCKSHIFT)) (DOIT ("2,13" "2,53" NOLOCKSHIFT)) (KEYPAD7 ("2,14" 55 NOLOCKSHIFT)) (KEYPAD8 (173
 56 NOLOCKSHIFT)) (KEYPAD9 ("2,15" 57 NOLOCKSHIFT)) (KEYPAD4 (172 52 NOLOCKSHIFT)) (KEYPAD5 ("2,16" 53
 NOLOCKSHIFT)) (KEYPAD6 (174 54 NOLOCKSHIFT)) (KEYPAD1 ("2,17" 49 NOLOCKSHIFT)) (KEYPAD2 (175 50 
NOLOCKSHIFT)) (KEYPAD3 ("2,20" 51 NOLOCKSHIFT)) (KEYPAD0 ("2,21" 48 NOLOCKSHIFT)) (KEYPAD%| ("|" 46 
NOLOCKSHIFT)) (KEYPAD\ ("\" 44 NOLOCKSHIFT)) (47 ("2,22" "2,62" NOLOCKSHIFT))))
(RPAQQ \DOVEOSDKEYACTIONS ((56 LOCKDOWN . LOCKUP) (36 CTRLDOWN . CTRLUP) (CAPSLOCK ("2,5" "2,45" 
NOLOCKSHIFT))))
(RPAQQ \MAIKOKEYACTIONS ((61 (5 7 NOLOCKSHIFT)) (91 (520 552 NOLOCKSHIFT)) (92 (513 545 NOLOCKSHIFT)) 
(30 (513 545 NOLOCKSHIFT)) (63 (516 548 NOLOCKSHIFT)) (93 (532 564 NOLOCKSHIFT)) (62) (111 (329 263 
NOLOCKSHIFT)) (89) (90 (515 547 NOLOCKSHIFT)) (73 (521 521 NOLOCKSHIFT)) (74 (522 522 NOLOCKSHIFT)) (
75 (2 2 NOLOCKSHIFT)) (81 (524 55 NOLOCKSHIFT)) (82 (173 56 NOLOCKSHIFT)) (83 (525 57 NOLOCKSHIFT)) (
84 (172 52 NOLOCKSHIFT)) (85 (526 53 NOLOCKSHIFT)) (87 (174 54 NOLOCKSHIFT)) (94 (527 49 NOLOCKSHIFT))
 (69 (175 50 NOLOCKSHIFT)) (70 (528 51 NOLOCKSHIFT)) (98 (529 48 NOLOCKSHIFT)) (76 (523 555 
NOLOCKSHIFT)) (72 LOCKTOGGLE) (97 (577 609 NOLOCKSHIFT)) (99 (578 610 NOLOCKSHIFT)) (100 (579 611 
NOLOCKSHIFT)) (67 (580 612 NOLOCKSHIFT)) (68 (581 613 NOLOCKSHIFT)) (101 (582 614 NOLOCKSHIFT)) (66 (
583 615 NOLOCKSHIFT)) (104 (584 616 NOLOCKSHIFT)) (80 (585 617 NOLOCKSHIFT)) (13 (23 21 NOLOCKSHIFT)) 
(33 (27 27 NOLOCKSHIFT)) (65 (27 27 NOLOCKSHIFT)) (2 (54 94 NOLOCKSHIFT)) (10 (45 95 NOLOCKSHIFT)) (36
 CTRLDOWN . CTRLUP) (56 LOCKTOGGLE . IGNORE) (45 (96 126 NOLOCKSHIFT)) (31 METADOWN . METAUP) (14 
METADOWN . METAUP) (71 (10 10 NOLOCKSHIFT)) (47 (530 562 NOLOCKSHIFT)) (105 (92 124 NOLOCKSHIFT))))
(RPAQQ \MAIKOKEYACTIONST4 ((61 ("^E" "^G" NOLOCKSHIFT)) (91 ("2,10" "2,50" NOLOCKSHIFT)) (92 ("2,1" 
"2,41" NOLOCKSHIFT)) (30 ("2,1" "2,41" NOLOCKSHIFT)) (109 ("2,25" "2,65" NOLOCKSHIFT)) (63 ("2,4" 
"2,44" NOLOCKSHIFT)) (14 METADOWN . METAUP) (93 ("2,24" "2,64" NOLOCKSHIFT)) (62) (111 ("1,111" "1,79"
 NOLOCKSHIFT)) (89) (90 ("2,3" "2,43" NOLOCKSHIFT)) (73 ("2,11" "2,11" NOLOCKSHIFT)) (74 ("2,12" 
"2,12" NOLOCKSHIFT)) (75 ("^B" "^B" NOLOCKSHIFT)) (81 ("2,14" 55 NOLOCKSHIFT)) (82 (173 56 NOLOCKSHIFT
)) (83 ("2,15" 57 NOLOCKSHIFT)) (84 (172 52 NOLOCKSHIFT)) (85 ("2,16" 53 NOLOCKSHIFT)) (87 (174 54 
NOLOCKSHIFT)) (94 ("2,17" 49 NOLOCKSHIFT)) (69 (175 50 NOLOCKSHIFT)) (70 ("2,20" 51 NOLOCKSHIFT)) (98 
("2,21" 48 NOLOCKSHIFT)) (76 ("2,13" "2,13" NOLOCKSHIFT)) (110 ("2,53" "2,53" NOLOCKSHIFT)) (72 
LOCKTOGGLE) (97 ("2,101" "2,141" NOLOCKSHIFT)) (99 ("2,102" "2,142" NOLOCKSHIFT)) (100 ("2,103" 
"2,143" NOLOCKSHIFT)) (67 ("2,104" "2,144" NOLOCKSHIFT)) (68 ("2,105" "2,145" NOLOCKSHIFT)) (101 (
"2,106" "2,146" NOLOCKSHIFT)) (66 ("2,107" "2,147" NOLOCKSHIFT)) (104 ("2,110" "2,150" NOLOCKSHIFT)) (
80 ("2,111" "2,151" NOLOCKSHIFT)) (106 ("2,113" "2,153" NOLOCKSHIFT)) (107 ("2,114" "2,154" 
NOLOCKSHIFT)) (108 ("2,115" "2,155" NOLOCKSHIFT)) (13 ("^W" "^U" NOLOCKSHIFT)) (33 ("ESC" "ESC" 
NOLOCKSHIFT)) (64 IGNORE . IGNORE) (65 (27 27 NOLOCKSHIFT)) (95 IGNORE . IGNORE) (96 IGNORE . IGNORE) 
(102 IGNORE . IGNORE) (2 ("6" "^" NOLOCKSHIFT)) (10 ("-" "_" NOLOCKSHIFT)) (36 CTRLDOWN . CTRLUP) (56 
LOCKTOGGLE . IGNORE) (45 ("`" "~" NOLOCKSHIFT)) (31 METADOWN . METAUP) (71 (10 10 NOLOCKSHIFT)) (47 (
"2,22" "2,62" NOLOCKSHIFT)) (86 IGNORE . IGNORE) (88 IGNORE . IGNORE) (105 ("\" "|" NOLOCKSHIFT))))
(RPAQQ \MAIKO-JLE-KEYACTIONS ((2 ("6" "&" NOLOCKSHIFT)) (4 ("7" "'" NOLOCKSHIFT)) (8 ("0" "0" 
NOLOCKSHIFT)) (10 ("\" "_" NOLOCKSHIFT)) (13 ("^W" "^U" NOLOCKSHIFT)) (14 METADOWN . METAUP) (15 (8 8 
NOLOCKSHIFT)) (17 ("2" "%"" NOLOCKSHIFT)) (22 ("9" ")" NOLOCKSHIFT)) (28 (":" "*" NOLOCKSHIFT)) (29 (
"[" "{" NOLOCKSHIFT)) (30 ("]" "}" NOLOCKSHIFT)) (31 METADOWN . METAUP) (33 ("ESC" "ESC" NOLOCKSHIFT))
 (36 CTRLDOWN . CTRLUP) (43 (";" "+" NOLOCKSHIFT)) (45 ("^" "~" NOLOCKSHIFT)) (47 ("2,22" "2,62" 
NOLOCKSHIFT)) (53 ("8" "(" NOLOCKSHIFT)) (56 LOCKTOGGLE . IGNORE) (58 ("@" "`" NOLOCKSHIFT)) (59 ("-" 
"=" NOLOCKSHIFT)) (61 ("^E" "^G" NOLOCKSHIFT)) (62) (63 ("2,4" "2,44" NOLOCKSHIFT)) (64 ("2,14" 55 
NOLOCKSHIFT)) (65 (27 27 NOLOCKSHIFT)) (66 ("2,107" "2,147" NOLOCKSHIFT)) (67 ("2,104" "2,144" 
NOLOCKSHIFT)) (69 ("2,13" "2,53" NOLOCKSHIFT)) (70 ("2,20" 51 NOLOCKSHIFT)) (71 (10 10 NOLOCKSHIFT)) (
72 (766 766 NOLOCKSHIFT)) (73 ("2,11" "2,11" NOLOCKSHIFT)) (74 ("2,12" "2,12" NOLOCKSHIFT)) (75 ("^B" 
"^B" NOLOCKSHIFT)) (80 ("2,111" "2,151" NOLOCKSHIFT)) (81 ("2,14" 55 NOLOCKSHIFT)) (82 (173 56 
NOLOCKSHIFT)) (83 ("2,15" 57 NOLOCKSHIFT)) (84 (172 52 NOLOCKSHIFT)) (85 ("2,16" 53 NOLOCKSHIFT)) (86 
(765 765 NOLOCKSHIFT)) (87 (174 54 NOLOCKSHIFT)) (88 (770 771 NOLOCKSHIFT)) (90 ("2,3" "2,43" 
NOLOCKSHIFT)) (91 ("2,10" "2,50" NOLOCKSHIFT)) (92 ("2,1" "2,41" NOLOCKSHIFT)) (93 ("2,24" "2,64" 
NOLOCKSHIFT)) (96 IGNORE . IGNORE) (98 ("2,21" 48 NOLOCKSHIFT)) (99 ("2,102" "2,142" NOLOCKSHIFT)) (
101 ("2,106" "2,146" NOLOCKSHIFT)) (102 IGNORE . IGNORE) (103 (767 768 NOLOCKSHIFT)) (104 ("2,110" 
"2,150" NOLOCKSHIFT)) (105 ("\" "|" NOLOCKSHIFT)) (106 ("2,113" "2,153" NOLOCKSHIFT)) (107 ("2,114" 
"2,154" NOLOCKSHIFT)) (108 ("2,115" "2,155" NOLOCKSHIFT)) (109 (769 769 NOLOCKSHIFT)) (110 ("2,53" 
"2,53" NOLOCKSHIFT)) (111 ("1,111" "1,79" NOLOCKSHIFT))))
(RPAQQ \TOSHIBA-KEYACTIONS ((2 ("6" "&" NOLOCKSHIFT)) (4 ("7" "'" NOLOCKSHIFT)) (17 ("2" "%"" 
NOLOCKSHIFT)) (53 ("8" "(" NOLOCKSHIFT)) (22 ("9" ")" NOLOCKSHIFT)) (8 ("0" "0" NOLOCKSHIFT)) (10 ("-"
 "=" NOLOCKSHIFT)) (59 ("^" "~" NOLOCKSHIFT)) (45 ("\" "|" NOLOCKSHIFT)) (58 ("@" "`" NOLOCKSHIFT)) (
29 ("[" "{" NOLOCKSHIFT)) (105 ("]" "}" NOLOCKSHIFT)) (43 (";" "+" NOLOCKSHIFT)) (28 (":" "*" 
NOLOCKSHIFT)) (15 (23 95 NOLOCKSHIFT)) (13 (8 8 NOLOCKSHIFT)) (86 METADOWN . METAUP) (73 (530 562 
NOLOCKSHIFT)) (88 ("2,24" "2,64" NOLOCKSHIFT)) (98 IGNORE . IGNORE) (75 ("2,11" "2,11" NOLOCKSHIFT)) (
110 ("2,12" "2,12" NOLOCKSHIFT)) (74 ("^B" "^B" NOLOCKSHIFT)) (64 ("2,14" 55 NOLOCKSHIFT)) (65 (173 56
 NOLOCKSHIFT)) (95 ("2,15" 57 NOLOCKSHIFT)) (81 (172 52 NOLOCKSHIFT)) (82 ("2,16" 53 NOLOCKSHIFT)) (83
 (174 54 NOLOCKSHIFT)) (84 ("2,17" 49 NOLOCKSHIFT)) (85 (175 50 NOLOCKSHIFT)) (87 ("2,20" 51 
NOLOCKSHIFT)) (94 ("2,21" 48 NOLOCKSHIFT)) (69 ("2,13" "2,53" NOLOCKSHIFT)) (70 LOCKTOGGLE)))
(RPAQQ KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS NIL)
(RPAQ? \KEYBOARD.META 256)
(RPAQ? \MODIFIED.KEYACTIONS)
(ADDTOVAR GLOBALVARS \RCLKSECOND \LASTUSERACTION \LASTKEYSTATE)
KEYACTION :D8
(L (2 TABLE 1 ACTIONS 0 KEYNAME)) �@d�	B�`Id	�7�lI	�*Id��d�� �	�Id�	��I�	�I	�lpH�Ad��gIHAd��gI(127 \KEYACTION1 109 \KEYACTION1 87 \ILLEGAL.ARG 80 \BLOCKDATAP 70 \BLOCKDATAP 59 \BLOCKDATAP 38 \#BLOCKDATACELLS 27 \BLOCKDATAP 9 \KEYNAMETONUMBER)
(121 IGNORE 103 IGNORE 17 \CURRENTKEYACTION)
()
KEYACTIONTABLE :D8
(L (0 OLD) F 1 KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS) S@����lk
-Hlpd�l���	�Hlpd�k��	�Hlpd�k��	�Hl�k�l������	�Hlpd�k��	
-�Hlpd�lp�lp�i
-�Hb`	Q
-
-��d	�9�l@	�,@d��d��"d�	��@d�	��@�	�@	�lk
-H@�	H@�	H@�	H@�	H@�	H@�
-	
-H@�	HdHH@��(331 KEYACTION 312 COPYALL 301 COPYALL 290 COPYALL 279 COPYALL 268 COPYALL 257 COPYALL 246 COPYALL 234 \ALLOCBLOCK 225 \ILLEGAL.ARG 218 \BLOCKDATAP 208 \BLOCKDATAP 196 \BLOCKDATAP 174 \#BLOCKDATACELLS 163 \BLOCKDATAP 154 \APPEND2 149 \APPEND2 143 \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS 138 COPY 121 \ALLOCBLOCK 101 \ALLOCBLOCK 85 \ALLOCBLOCK 64 \ALLOCBLOCK 48 \ALLOCBLOCK 32 \ALLOCBLOCK 14 \ALLOCBLOCK)
(133 \ORIGKEYACTIONS)
()
KEYBOARDTYPE :D8
NIL ~Hdg�R�o		o
-�No			�8oo	
-�"gg�Hdg�g�H(89 STREQUAL 84 UNIX-GETPARM 67 MKATOM 62 U-CASE 57 UNIX-GETENV 43 SASSOC 33 L-CASE 28 UNIX-GETENV 4 MACHINETYPE)
(119 DOVE 112 DANDELION 102 DORADO 96 FULL-IBMPC 14 MAIKO)
( 79 "ARCH" 74 "dos" 52 "LDEKBDTYPE" 38 (("type3" SUN3) ("type4" SUN4) ("type5" SUN5)) 23 "LDEKBDTYPE")
RESETKEYACTION :D8
(L (2 RESETINTERRUPTS 1 FROM 0 TABLE)) �@d	�9�l@	�,@d��d��"d�	��@d�	��@�	�@	�A�	`b	�3lA	�(Ad����A�	�A�	�A�	�@	�@�A�@�	��@�A�@�	��@�A�@�	��B�@�A�@�	�Ŀ@A�	@(219 COPY 207 \#BLOCKDATACELLS 188 \#BLOCKDATACELLS 172 \#BLOCKDATACELLS 156 \#BLOCKDATACELLS 141 \ILLEGAL.ARG 134 \BLOCKDATAP 125 \BLOCKDATAP 115 \BLOCKDATAP 94 \#BLOCKDATACELLS 84 \BLOCKDATAP 68 \ILLEGAL.ARG 61 \BLOCKDATAP 51 \BLOCKDATAP 39 \BLOCKDATAP 17 \#BLOCKDATACELLS 6 \BLOCKDATAP)
(77 \DEFAULTKEYACTION)
()
\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS :D8
(F 1 \MAIKOKEYACTIONS F 2 \MAIKOKEYACTIONST4 F 3 \MAIKO-JLE-KEYACTIONS F 4 \TOSHIBA-KEYACTIONS) �`dl�`dl�`dl�o�o	o��o`�!l�j��QH
-`�!l�k��RH
-`�!l�l��S`�!l�l��RT
-Ql� l�``
-`(170 \APPEND2 151 \DoveMisc.ReadKeyboardType 138 \APPEND2 100 \APPEND2 79 \APPEND2 43 UNIX-GETPARM)
(176 \DOVEKEYACTIONS 165 \DOVEOSDKEYACTIONS 160 \DOVEKEYACTIONS 122 \InterfacePage 106 \InterfacePage 85 \InterfacePage 64 \InterfacePage 25 \DLIONKEYACTIONS 14 \DORADOKEYACTIONS 4 \MACHINETYPE)
( 56 ((56 LOCKDOWN . LOCKUP) (72 LOCKDOWN . LOCKUP)) 48 "X" 38 "DISPLAY")
\KEYACTION1 :D8
(L (2 TABLE 1 ACTION 0 TI)) )B�@�dj�g�dl�dl�n�B�@��dn���j��gB�@���hB�@��dn���j��gB�@lp�lp����hB�
-@��B�@�l�g�gh��dk�g��dl�g��dl�g�sdl�%�gB�@���B�@lp�lp����h�Jdl�g�<dl	�g�.dl�g� dl
-�g�dl�g�dl�g��dl�g��dl
�g��dl�g��dl�g��dl�g��dl�g��dl�g��dl�g��dl�g�xdl�g�kdl�g�^dl�g�Qdl�g�Ddl�g�7dl�g�*dl�g�dl�g�l�g�A��GAdg�g�B�@jǿAdg�B�@kǿg�B�@lǿAdg�B�@lǿg�B�@l	ǿAdg�B�@lǿg�B�@l
-ǿAdg�B�@lǿg�B�@lǿAdg�B�@lǿg�B�@lǿAdg�B�@lǿg�B�@l
ǿAdg�B�@lǿg�B�@lǿAdg�B�@lǿg�B�@lǿAdg�B�@lǿg�B�@lǿAdg�B�@lǿg�B�@lǿAdg�B�@lǿg�B�@lǿAdg�B�@lǿg�B�@lǿAdg�B�@lǿg�B�@lǿAg�B�@lǿ�Ad�xdg�l�0A�Rd_^�jN�O�
OkgO_�jO�O�
Okg_�O�	Oh_�O&_���O\�n��X�"A	X�jH�AkgX���Ad���dg�r�0A�Td__�jO�O�
OkgO_�jO�O�
Okg_�O�	Oh_�O&_���O]�n��Y�A�!A[	Y�jI�KkgY�K[d��A	�dg�di�B�@lǰhdg�d��B�@lǰT�K	Z�jJ�KkgZ��K[d���Kdg�di�B�@lǰdg�d��B�@lǁ�h���yB�@�H��B�@�I��B�@��L�B�lpd�@���M�J���PB�
-@�J���D(1438 \GETCHARCODE 1384 \ILLEGAL.ARG 1350 \GETCHARCODE 1182 \GETCHARCODE 545 SHOULDNT)
(1497 NOLOCKSHIFT 1475 LOCKSHIFT 1454 CHARCODE 1416 NOLOCKSHIFT 1394 LOCKSHIFT 1366 CHARCODE 1299 CHARCODE 1270 CHARCODE 1226 DEADKEY 1199 CHARCODE 1136 CHARCODE 1107 CHARCODE 1066 DEADKEY 1036 ALTGRTOGGLE 1019 ALTGRDOWN 1002 ALTGRUP 984 USERMODE3TOGGLE 967 USERMODE3DOWN 949 USERMODE3UP 932 USERMODE2TOGGLE 914 USERMODE2DOWN 897 USERMODE2UP 879 USERMODE1TOGGLE 862 USERMODE1DOWN 844 USERMODE1UP 827 FONTTOGGLE 809 FONTDOWN 792 FONTUP 774 METADOWN 757 METAUP 739 LOCKTOGGLE 722 LOCKDOWN 704 LOCKUP 687 2SHIFTDOWN 669 2SHIFTUP 652 1SHIFTDOWN 634 1SHIFTUP 617 CTRLDOWN 599 CTRLUP 583 EVENT 566 IGNORE 557 NOCHANGE 539 ALTGRTOGGLE 529 ALTGRDOWN 516 ALTGRUP 503 USERMODE3TOGGLE 490 USERMODE3DOWN 477 USERMODE3UP 464 USERMODE2TOGGLE 451 USERMODE2DOWN 438 USERMODE2UP 425 USERMODE1TOGGLE 411 USERMODE1DOWN 397 USERMODE1UP 383 FONTTOGGLE 369 FONTDOWN 355 FONTUP 341 METAUP 327 METADOWN 313 LOCKTOGGLE 299 LOCKUP 285 LOCKDOWN 271 2SHIFTUP 257 2SHIFTDOWN 243 1SHIFTUP 229 1SHIFTDOWN 189 DEADKEY 174 CTRLUP 160 CTRLDOWN 146 EVENT 128 NOLOCKSHIFT 122 LOCKSHIFT 84 DEADKEY 51 DEADKEY 14 IGNORE)
()
KEYDOWNP :D8
(L (0 KEYNAME)) /`@	2I���lIl�ٺkJ缻LHK��j�j�kj�(10 \KEYNAMETONUMBER)
(4 \LASTKEYSTATE)
()
KEYNUMBERP :D8
(L (0 X)) @�j@�h�	lp@�@NIL
NIL
()
\KEYNAMETONUMBER :D8
(L (0 KEYNAME)) b`j"H�%@d	[�`jL�%h�@	�@J�J�@J�IH�IkԹ���KN�N�KN�M��L�MkԽ��(46 \ILLEGAL.ARG 19 L-CASE)
(28 \KEYNAMES 4 \KEYNAMES)
()
MODIFY.KEYACTIONS :D8
(L (1 SaveCurrent? 0 KeyActions)) ZA�+@@�d[K	�I�HhZ�H&���J@�(do�d�HHI	���h��(76 KEYACTION 71 EVAL 19 KEYACTION)
(43 \MODIFIED.KEYACTIONS)
( 56 (\CURRENTKEYACTION \COMMANDKEYACTION))
METASHIFT :D8
(L (0 FLG)) :eogHj�kai�I�ka�g`
-ddI��i(49 KEYACTION)
(42 \ORIGKEYACTIONS 37 BLANK-BOTTOM 16 BLANK-BOTTOM)
( 8 (METADOWN . METAUP))
SHIFTDOWNP :D8
(L (0 SHIFT)) 
-@g��@dg�`�	pj�h�g�`�	0j�h�a`�	@j�h�@dg�`�	0j�h�g��@dg�,�`�	0j�h�`�	@j�h�`�	Pj�h�g�`�	`j�h�@dg�`�	�j�h�g�`�	�j�h�@dg�`�	�j�h�g�`�	�j�h�@	(263 \ILLEGAL.ARG)
(249 \LASTKEYSTATE 242 USERMODE3 229 \LASTKEYSTATE 221 USERMODE2 206 \LASTKEYSTATE 199 USERMODE1 186 \LASTKEYSTATE 178 FONT 163 \LASTKEYSTATE 156 CTRL 143 \LASTKEYSTATE 129 \LASTKEYSTATE 115 \LASTKEYSTATE 106 SHIFTORLOCK 96 2SHIFT 83 \LASTKEYSTATE 75 1SHIFT 60 \LASTKEYSTATE 46 \LASTKEYSTATE 38 SHIFT 25 \LASTKEYSTATE 17 META 5 LOCK)
()
SETUP.OFFICE.KEYBOARD :D8
NIL -dg�`	g�`	(42 MODIFY.KEYACTIONS 23 MODIFY.KEYACTIONS 4 MACHINETYPE)
(37 \DOVEOSDKEYACTIONS 29 DOVE 18 \DLIONOSDKEYACTIONS 10 DANDELION)
()
optimize-\KEYNAMETONUMBER :D8
(L (2 $$CTX 1 $$ENV 0 $$WHOLE)) @	�g	(21 \KEYNAMETONUMBER 7 CONSTANTEXPRESSIONP)
(14 IGNOREMACRO)
()
(PUTPROP (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-\KEYNAMETONUMBER) (GET (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROPS \TEMPCOPYTIMER MACRO ((X) (PROGN (\BLT \MOUSETIMERTEMP (LOCF X) WORDSPERCELL) 
\MOUSETIMERTEMP)))
(PUTPROPS XKEYDOWNP MACRO ((KEYNAME) (KEYDOWNP1 (\KEYNAMETONUMBER KEYNAME))))
(PUTPROPS KEYDOWNP1 MACRO (OPENLAMBDA (KEYNUMBER) (DECLARE (GLOBALVARS \EM.KBDAD0 \EM.KBDAD1 
\EM.KBDAD2 \EM.KBDAD3 \EM.UTILIN \EM.KBDAD4 \EM.KBDAD5)) (PROG NIL (RETURN (EQ 0 (LOGAND (LRSH (LLSH 1
 15) (PROGN (* (IMOD KEYNUMBER BITSPERWORD) - GETD cause IMOD and BITSPERWORD not exported to user) (
LOGAND KEYNUMBER 15))) (\GETBASE (SELECTQ (PROGN (* (FOLDLO KEYNUMBER BITSPERWORD) GETD follows since 
FOLDLO and BITSPERWORD not exported to user) (LRSH KEYNUMBER 4)) (0 \EM.KBDAD0) (1 \EM.KBDAD1) (2 
\EM.KBDAD2) (3 \EM.KBDAD3) (4 \EM.UTILIN) (5 (OR \EM.KBDAD4 (RETURN))) (6 (OR \EM.KBDAD5 (RETURN))) (
RETURN)) 0)))))))
(PUTPROPS \NEWKEYDOWNP MACRO ((KEYNUMBER) (EQ 0 (\GETBASEBIT \LASTKEYSTATE KEYNUMBER))))
\INIT.KEYBOARD.STREAMA0008 :D8
(L (1 MODE 0 X)) Ag�`NIL
(13 \KEYBOARD.STREAM 5 INPUT)
()
\INIT.KEYBOARD.STREAM :D8
NIL �g`dg�dg�dg
-�dg,�dg0�dg:�dg<�dg�dgh�dgR�dgP�dgN�dgH�dgB�dg@�dg>�dg8�dg6�dg4�dg2�dg*�dg �dg�dg�dg�dg�dg�
-ldj�0�dj��dg�d`
-�dn���5�`HdI�4�dh2�d`.�dg*�dg(�dg&�dg$�`HdI��dj�dj�dj�0�dj��dj��dl��dh�dj��dg
-�(439 \SETACCESS 263 \DEFINEDEVICE)
(445 \KEYBOARD.STREAM 434 INPUT 373 FILELINELENGTH 365 \STREAM.NOT.OPEN 356 \STREAM.NOT.OPEN 347 \FILEOUTCHARFN 338 \EOSERROR 329 \NOIMAGEOPS 308 \STREAM.DEFAULT.MAXBUFFERS 293 \KEYBOARD.DEVICE 284 {KEYBOARD} 258 \KEYBOARD.DEVICE 250 NILL 241 NILL 232 \GENERIC.RENAMEFILE 223 NILL 214 NILL 205 NILL 196 NILL 187 \GENERIC.READCHAR 178 \GENERIC.WRITECHAR 169 \GENERIC.PEEKCHAR 160 \GENERIC.UNREADCHAR 151 \GENERIC.BINS 142 \GENERIC.BOUTS 133 NILL 124 \GENERIC.CHARSET 115 \ILLEGAL.DEVICEOP 106 \IS.NOT.RANDACCESSP 97 \IS.NOT.RANDACCESSP 88 \GENERIC.READCCODE 79 \INIT.KEYBOARD.STREAMA0008 70 NILL 61 \SYSBUFP 52 \PEEKSYSBUF 43 \GETKEY 34 \KEYBOARDEVENTFN 25 NILL 16 KEYBOARD 9 |FDEVTYPE#| 4 KEYBOARD)
()
(\INIT.KEYBOARD.STREAM)
\DOBUFFEREDTRANSITIONS :D8
(P 4 \INTERRUPTABLE P 0 PENDINGINTERRUPT I 0 \INTERRUPTABLE) _g@`�Zj�"`j`�	0j�p`j�k�n`J�[d�`�� �j`�K��`K���K�`��l`�K��`K���Kd�`��!�l `�K��`K���K�`��l0`�K��`K���Kd�`��!�lP`�K��`K���K�`��l``�K��`K���K�`��l@`�K��`K���`n�J�l�lJ�Y��I`����`j����v`j�l��ǿ`j`�	@j�`j�l�`j�l��ǿ`j`�	Pj�`j�l�`j�l��ǿ`k`�	`j�d�jǿ`l`�	pj�k�jǿ`l`�	�j�`l�l�`l�l��ǿ`l`�	�j�`l�k�`l�l��ǿ`l`�	�j�`l�l�`l�l��ǿ`l`�	�j�`l�l�`l�l��ǿ`l`�	�j�`l�l�`l�l��ǿ`l`�	�j�`l�l �`l�l���H�`�hg/��ihhdi(860 INTERRUPTED 350 \DOTRANSITIONS 308 \DOTRANSITIONS 266 \DOTRANSITIONS 222 \DOTRANSITIONS 180 \DOTRANSITIONS 136 \DOTRANSITIONS 94 \DOTRANSITIONS)
(851 \KEYBUFFERING 845 \PENDINGINTERRUPT 838 \KEYBUFFERING 832 \PENDINGINTERRUPT 822 \INTERRUPTABLE 816 \KEYBUFFERING 809 \PENDINGINTERRUPT 795 \SHIFTSTATE 783 \SHIFTSTATE 772 \LASTKEYSTATE 765 \SHIFTSTATE 752 \SHIFTSTATE 740 \SHIFTSTATE 729 \LASTKEYSTATE 722 \SHIFTSTATE 709 \SHIFTSTATE 697 \SHIFTSTATE 686 \LASTKEYSTATE 679 \SHIFTSTATE 666 \SHIFTSTATE 654 \SHIFTSTATE 643 \LASTKEYSTATE 636 \SHIFTSTATE 623 \SHIFTSTATE 612 \SHIFTSTATE 601 \LASTKEYSTATE 594 \SHIFTSTATE 581 \SHIFTSTATE 569 \SHIFTSTATE 558 \LASTKEYSTATE 551 \SHIFTSTATE 535 \LASTKEYSTATE 528 \SHIFTSTATE 512 \LASTKEYSTATE 506 \SHIFTSTATE 494 \SHIFTSTATE 483 \SHIFTSTATE 472 \LASTKEYSTATE 466 \SHIFTSTATE 454 \SHIFTSTATE 443 \SHIFTSTATE 432 \LASTKEYSTATE 426 \SHIFTSTATE 414 \SHIFTSTATE 402 \KEYBOARDEVENTQUEUE 390 \KEYBOARDEVENTQUEUE 367 \KEYBOARDEVENTQUEUE 356 \LASTKEYSTATE 340 \LASTKEYSTATE 328 \LASTKEYSTATE 314 \LASTKEYSTATE 298 \LASTKEYSTATE 286 \LASTKEYSTATE 272 \LASTKEYSTATE 256 \LASTKEYSTATE 243 \LASTKEYSTATE 228 \LASTKEYSTATE 212 \LASTKEYSTATE 200 \LASTKEYSTATE 186 \LASTKEYSTATE 170 \LASTKEYSTATE 157 \LASTKEYSTATE 142 \LASTKEYSTATE 126 \LASTKEYSTATE 114 \LASTKEYSTATE 100 \LASTKEYSTATE 84 \LASTKEYSTATE 72 \LASTKEYSTATE 61 \KEYBOARDEVENTQUEUE 49 \SHIFTSTATE 35 \LASTKEYSTATE 29 \SHIFTSTATE 17 \KEYBOARDEVENTQUEUE 9 \KEYBUFFERING 4 INPROGRESS)
()
\TIMER.INTERRUPTFRAME :D8
NIL hNIL
NIL
()
\PERIODIC.INTERRUPTFRAME :D8
NIL `H�jHNIL
(4 \PERIODIC.INTERRUPT)
()
(RPAQ? \KEYBUFFERING)
(RPAQ? \PERIODIC.INTERRUPT)
(RPAQ? \TIMER.INTERRUPT.PENDING)
(RPAQ? \PERIODIC.INTERRUPT.FREQUENCY 77)
\HARDCURSORUP :D8
(L (1 INVERTFLG 0 NEWCURSOR)) �h@d�Xd�`��@`�
-�@�X�Hjd`jlH��ldA�g�gg
-`dl�`	��l�@�@�}@h(143 \DoveDisplay.SetCursorShape 122 BKBITBLT 64 \CURSORBITSPERPIXEL)
(165 CURSOR 157 CURSOR 138 CursorBitMap 127 \MACHINETYPE 116 REPLACE 111 INPUT 105 INVERT 92 BITMAP 83 CursorBitMap 71 CURSOR 57 BITMAP 52 \CURSORDESTINATION 41 BITMAP 36 \CURSORDESTINATION 29 BITMAP 20 CURSOR 14 \CURRENTCURSOR 8 \SOFTCURSORP)
()
\HARDCURSORPOSITION :D8
(L (1 YPOS 0 XPOS)) �`k�A�bj@�j�`@�`kـ@`�n���bjA�j�`A�`kـA`�n���b`dl��dn��jb�@n��jb�`dl�@A
-�Odl�@A}A�Bl�>`@�)�`A�*�n�`���`@�)�`A�*�`n���`@��`A�`@��`A�h(132 \DoveMisc.SetMousePosition)
(243 \EM.CURSORY 234 \EM.CURSORX 226 \EM.MOUSEY 217 \EM.MOUSEX 206 \IOPAGE 197 \IOPAGE 188 \IOPAGE 178 \IOPAGE 166 \IOPAGE 157 \IOPAGE 119 \MACHINETYPE 87 \MACHINETYPE 75 \CURSORHOTSPOTY 66 \CURSORDESTHEIGHT 58 \CURSORDESTHEIGHT 39 \CURSORHOTSPOTX 30 \CURSORDESTWIDTH 22 \CURSORDESTWIDTH 4 \CURSORDESTHEIGHT)
()
\HARDCURSORDOWN :D8
NIL `	(9 \CLEARBM)
(4 CursorBitMap)
()
CURSOR.INIT :D8
NIL ~p`hdj`�`�`�`�d����X`dHn�����Ydk�
-�Ij�
-@�Ij�
-Q�d	`dj��dj��Zdk�
-�Jj�
-@�Jj�
-Q�d	`dj��dj��[dk�
-�Kk�
-@�Kk�
-Q�d	`dj��dj��\dk�
-�Lj�
-@�Ll�
-Q�d	`dHn�����]dk�
-�Mj�
-@�Mj�
-Q�d	`dHn�����^dk�
-�Nj�
-@�Nj�
-Q�d	h(378 \LOCKCELL 333 \LOCKCELL 288 \LOCKCELL 241 \LOCKCELL 195 \LOCKCELL 149 \LOCKCELL)
(372 \SOFTCURSORBBT6 338 |PILOTBBTTYPE#| 327 \SOFTCURSORBBT5 293 |PILOTBBTTYPE#| 282 \SOFTCURSORBBT4 246 |PILOTBBTTYPE#| 235 \SOFTCURSORBBT3 200 |PILOTBBTTYPE#| 189 \SOFTCURSORBBT2 154 |PILOTBBTTYPE#| 143 \SOFTCURSORBBT1 109 |PILOTBBTTYPE#| 98 \CURSORDESTRASTERWIDTH 91 BITMAP 86 ScreenBitMap 81 \CURSORDESTHEIGHT 74 BITMAP 69 ScreenBitMap 64 \CURSORDESTWIDTH 57 BITMAP 52 ScreenBitMap 47 \CURSORDESTLINEBASE 40 BITMAP 35 ScreenBitMap 30 \CURSORDESTLINE 24 \SOFTCURSORDOWNBM 18 \SOFTCURSORUPBM 12 \CURSORDESTINATION 7 ScreenBitMap)
()
\CURSORDESTINATION :D8
(L (0 DESTINATION) P 1 \INTERRUPTABLE) N@`�@`��@��`@�
-�`dl�jd
-�Odl�jd}A�Bl�>`j�)�`j�*�n�`���`j�)�`j�*�`n���`j��`j��`j��`j��j�g�@���@��@��@�����`Hn�����`Hn�����`Hn�����@h(83 \DoveMisc.SetMousePosition 64 \CURSORBITSPERPIXEL)
(330 \CURSORDESTINATION 316 PILOTBBT 311 \SOFTCURSORBBT6 298 PILOTBBT 293 \SOFTCURSORBBT5 280 PILOTBBT 275 \SOFTCURSORBBT1 265 \CURSORDESTRASTERWIDTH 258 BITMAP 251 \CURSORDESTHEIGHT 244 BITMAP 237 \CURSORDESTWIDTH 230 BITMAP 219 BITMAP 211 \CURSORDESTLINEBASE 205 \CURSORDESTLINE 195 \EM.CURSORY 186 \EM.CURSORX 177 \EM.MOUSEY 168 \EM.MOUSEX 157 \IOPAGE 148 \IOPAGE 139 \IOPAGE 129 \IOPAGE 117 \IOPAGE 108 \IOPAGE 70 \MACHINETYPE 57 BITMAP 51 \CURRENTCURSOR 41 BITMAP 33 BITMAP 26 CURSOR 21 \CURRENTCURSOR 8 \CURSORDESTINATION)
()
\SOFTCURSORUP :D8
(L (0 NEWCURSOR)) ��
-@�X@�YH�ZH�\H�]`��4`�J�$`�L�`�M��J�L�JLM�JLM�`�_k
-�`�_k
-�H�����H�H�ڻ`Nn�����`O���`O���`Nn�����`O���`O���`Nn�����`K��`L�	�`O���`O���`Nn�����`Nn�����`K��`L�	�`O���`O���`Nn�����`Nn�����`K��`L�	�`Nn�����`Nn�����I�_�`O���`O���H�_�`O���`O���@dk
-ih(708 \SOFTCURSORUPCURRENT 697 \TEMPLOCKPAGES 192 \TEMPLOCKPAGES 171 \TEMPLOCKPAGES 145 BITMAPCREATE 131 BITMAPCREATE)
(703 \SOFTCURSORP 690 \CURRENTCURSOR 678 PILOTBBT 673 \SOFTCURSORBBT4 662 PILOTBBT 657 \SOFTCURSORBBT4 647 BITMAP 635 PILOTBBT 630 \SOFTCURSORBBT3 619 PILOTBBT 614 \SOFTCURSORBBT3 604 BITMAP 590 PILOTBBT 585 \SOFTCURSORBBT6 572 PILOTBBT 567 \SOFTCURSORBBT5 558 PILOTBBT 553 \SOFTCURSORBBT4 544 PILOTBBT 539 \SOFTCURSORBBT4 526 PILOTBBT 521 \SOFTCURSORBBT4 508 PILOTBBT 503 \SOFTCURSORBBT4 492 PILOTBBT 487 \SOFTCURSORBBT4 476 PILOTBBT 471 \SOFTCURSORBBT4 462 PILOTBBT 457 \SOFTCURSORBBT3 448 PILOTBBT 443 \SOFTCURSORBBT3 430 PILOTBBT 425 \SOFTCURSORBBT3 412 PILOTBBT 407 \SOFTCURSORBBT3 396 PILOTBBT 391 \SOFTCURSORBBT3 380 PILOTBBT 375 \SOFTCURSORBBT3 366 PILOTBBT 361 \SOFTCURSORBBT2 352 PILOTBBT 347 \SOFTCURSORBBT2 334 PILOTBBT 329 \SOFTCURSORBBT2 318 PILOTBBT 313 \SOFTCURSORBBT2 302 PILOTBBT 297 \SOFTCURSORBBT2 284 PILOTBBT 279 \SOFTCURSORBBT2 268 PILOTBBT 263 \SOFTCURSORBBT2 252 PILOTBBT 247 \SOFTCURSORBBT2 234 PILOTBBT 229 \SOFTCURSORBBT1 220 BITMAP 212 BITMAP 199 BITMAP 182 BITMAP 177 \SOFTCURSORDOWNBM 161 BITMAP 156 \SOFTCURSORUPBM 150 \SOFTCURSORDOWNBM 136 \SOFTCURSORUPBM 122 \SOFTCURSORHEIGHT 115 \SOFTCURSORWIDTH 101 BITMAP 96 \SOFTCURSORUPBM 85 BITMAP 80 \SOFTCURSORUPBM 69 BITMAP 64 \SOFTCURSORUPBM 57 BITMAP 52 \SOFTCURSORUPBM 44 BITMAP 35 BITMAP 26 BITMAP 17 CURSOR 8 CURSOR)
()
\SOFTCURSORUPCURRENT :D8
NIL $�`��`j��i�`�dn��n���kٹ`�dn��n���kٺj[�`�`�jI�jIٻMKٽj��IM�`�`IٽjM�OjJ�jJټNLپj��JN�`�`JپjN�&`J�Aj`�_�`dJ��`��_IڹOKڻOMڽ`_�I_�L`��_�`�O�_�`�O�_�K_�`O���`O���`O��`O���`O���`O��`M��`N�	�`O���`O���`O��`O���`O���`O��`M��`N�	�`O���`O���`O��`O���`O���`O��`M��`N�	�`jv�`jv�`jv�`jv�`j
-�`H�hk��g�`O�����J`���`dJ���k��g�``�����(709 \SOFTCURSORPILOTBITBLT)
(796 \CURSORDESTRASTERWIDTH 791 \CURSORDESTLINEBASE 784 \CURSORDESTLINEBASE 778 \CURSORDESTLINE 764 \CURSORDESTLINE 754 \CURSORDESTLINE 740 \CURSORDESTLINEBASE 733 \CURSORDESTLINEBASE 727 \CURSORDESTLINE 715 \EM.DISPINTERRUPT 703 \SOFTCURSORBBT5 695 \SOFTCURSORBBT4 687 \SOFTCURSORBBT3 679 \SOFTCURSORBBT2 671 \SOFTCURSORBBT1 662 PILOTBBT 657 \SOFTCURSORBBT6 648 PILOTBBT 643 \SOFTCURSORBBT6 633 PILOTBBT 628 \SOFTCURSORBBT6 617 PILOTBBT 612 \SOFTCURSORBBT6 601 PILOTBBT 596 \SOFTCURSORBBT6 586 PILOTBBT 581 \SOFTCURSORBBT6 570 PILOTBBT 565 \SOFTCURSORBBT6 554 PILOTBBT 549 \SOFTCURSORBBT6 540 PILOTBBT 535 \SOFTCURSORBBT5 526 PILOTBBT 521 \SOFTCURSORBBT5 511 PILOTBBT 506 \SOFTCURSORBBT5 495 PILOTBBT 490 \SOFTCURSORBBT5 479 PILOTBBT 474 \SOFTCURSORBBT5 464 PILOTBBT 459 \SOFTCURSORBBT5 448 PILOTBBT 443 \SOFTCURSORBBT5 432 PILOTBBT 427 \SOFTCURSORBBT5 418 PILOTBBT 413 \SOFTCURSORBBT1 404 PILOTBBT 399 \SOFTCURSORBBT1 389 PILOTBBT 384 \SOFTCURSORBBT1 373 PILOTBBT 368 \SOFTCURSORBBT1 357 PILOTBBT 352 \SOFTCURSORBBT1 342 PILOTBBT 337 \SOFTCURSORBBT1 326 PILOTBBT 321 \SOFTCURSORBBT1 310 PILOTBBT 305 \SOFTCURSORBBT1 288 BITMAP 283 \SOFTCURSORDOWNBM 270 BITMAP 265 \SOFTCURSORUPBM 254 BITMAP 249 \SOFTCURSORUPBM 236 \CURSORDESTLINEBASE 214 BITMAP 207 CURSOR 202 \CURRENTCURSOR 189 \CURSORDESTLINE 180 \CURSORDESTRASTERWIDTH 168 \CURSORDESTLINE 153 \CURSORDESTHEIGHT 146 \CURSORDESTHEIGHT 112 \CURSORDESTWIDTH 105 \CURSORDESTWIDTH 80 \SOFTCURSORHEIGHT 74 \SOFTCURSORWIDTH 51 \EM.MOUSEY 31 \EM.MOUSEX 25 \SOFTCURSORUPP 15 \EM.DISPINTERRUPT 7 \EM.DISPINTERRUPT)
()
\SOFTCURSORPOSITION :D8
(L (1 Y 0 X)) E`�X`j�`�@�`�A�`���`H�h(56 \SOFTCURSORUPCURRENT 50 \SOFTCURSORDOWN)
(62 \EM.DISPINTERRUPT 44 \SOFTCURSORUPP 33 \EM.CURSORY 23 \EM.CURSORX 15 \EM.DISPINTERRUPT 7 \EM.DISPINTERRUPT)
()
\SOFTCURSORDOWN :D8
NIL /`�X`j�h`j
-`H�h(35 \SOFTCURSORPILOTBITBLT)
(40 \EM.DISPINTERRUPT 29 \SOFTCURSORBBT6 24 \SOFTCURSORUPP 15 \EM.DISPINTERRUPT 7 \EM.DISPINTERRUPT)
()
CURSORPROP :D8
(L (0 X)) 0eHdl�kalalal�
kala
-	(45 \ILLEGAL.ARG 39 GETCURSORPROP 23 PUTCURSORPROP)
NIL
()
GETCURSORPROP :D8
(L (1 PROP 0 CURSOR)) @�A'NIL
(5 CURSOR)
()
PUTCURSORPROP :D8
(L (2 VALUE 1 PROP 0 CURSOR) P 1 OLDVALUE) d0@�Xd�EdA'�B�HAB�DI�BHdA�%�@@��%A�Jd��JZ��B�@ABhI(28 LISTPUT)
(89 CURSOR 53 CURSOR 47 CURSOR 8 CURSOR)
()
\CURSORBITSPERPIXEL :D8
(L (1 NEWBITSPERPIXEL 0 CURSOR)) �p@��XdA��@�Y@�Z@H	I@H	J@A	
-]�@A	
-�1kA�kٻj�@g
-LKA�@g
-LKA�@M@Nh(144 COLORIZEBITMAP 136 CURSORPROP 124 COLORIZEBITMAP 116 CURSORPROP 95 CURSORPROP 90 \CURSORMASKPROPNAME 81 CURSORPROP 76 \CURSORIMAGEPROPNAME 69 CURSORPROP 63 \CURSORMASKPROPNAME 56 CURSORPROP 50 \CURSORIMAGEPROPNAME)
(160 CURSOR 151 CURSOR 131 MASK1 111 IMAGE1 40 CURSOR 31 CURSOR 15 BITMAP 8 CURSOR)
()
\CURSORIMAGEPROPNAME :D8
(L (0 BITSPERPIXEL)) '@dk�gdl�gl�g(36 SHOULDNT)
(30 IMAGE8 20 IMAGE4 9 IMAGE1)
()
\CURSORMASKPROPNAME :D8
(L (0 BITSPERPIXEL)) '@dk�gdl�gl�g(36 SHOULDNT)
(30 MASK8 20 MASK4 9 MASK1)
()
CURSORCREATE :D8
(L (4 DATA 3 HOTSPOTY 2 HOTSPOTX 1 MASK 0 IMAGE)) �A3 �A	�Bb�Ab�hb�@d	l�)�@	l�@�A��	l�A	l�A	�B	�Bb�Bb�`d@�A�@HdI�@	k�B3 �jHdI�IjH�H�jHdI�@	k�C3 �
-@	k�HdI�IjH�H�jHdI�dD�(186 BITMAPHEIGHT 173 BITMAPHEIGHT 127 BITMAPWIDTH 85 POSITIONP 78 \ILLEGAL.ARG 68 BITMAPHEIGHT 58 BITMAPWIDTH 41 BITMAPHEIGHT 29 BITMAPWIDTH 9 POSITIONP)
(101 |CURSORTYPE#|)
()
CURSOR :D8
(L (1 INVERTFLG 0 NEWCURSOR)) m`X@di�`b`
-�?�@A
-�@��@��k�@����@�H	���(104 \ILLEGAL.ARG 46 \CURSORUP 38 \CURSORDOWN 31 \CURSOR-VALID-P)
(92 \CURSORHOTSPOTY 84 CURSOR 74 BITMAP 67 CURSOR 60 \CURSORHOTSPOTX 53 CURSOR 26 \SOFTCURSORP 19 DEFAULTCURSOR 7 \CURRENTCURSOR)
()
\CURSOR-VALID-P :D8
(L (1 SOFT? 0 CURSOR)) [@	�SA�i@�@�@�H	l�h�'H	l�h�jI�h�lI�
jJ�h�lJ�(57 BITMAPHEIGHT 44 BITMAPWIDTH 5 CURSORP)
(33 CURSOR 25 CURSOR 17 CURSOR)
()
\CURSORUP :D8
(L (1 INVERTFLG 0 NEWCURSOR) P 0 \INTERRUPTABLE) �@`�
-@�@��B@d��l�.�@d��l��``�@A
-�@	�`@��@��k�@��`�
-(161 ADJUSTCURSORPOSITION 109 \SOFTCURSORUP 102 \HARDCURSORUP 20 \CURSORBITSPERPIXEL)
(155 \CURSORHOTSPOTY 147 CURSOR 137 BITMAP 130 CURSOR 121 CURSOR 115 \CURSORHOTSPOTX 93 ScreenBitMap 88 \CURSORDESTINATION 75 BITMAP 68 CURSOR 53 BITMAP 46 CURSOR 34 CURSOR 26 CURSOR 13 BITMAP 8 \CURSORDESTINATION)
()
\CURSORPOSITION :D8
(L (1 YPOS 0 XPOS)) `k�A�b`@�`kـ@`�n���b`A�`kـA`�n���b`dl��dn��jb�@n��jb�`dl�@A
-�Odl�@A}A�Bl�>`@�)�`A�*�n�`���`@�)�`A�*�`n���`@��`A�`�@A
-�`@��`A��`l�
-@A
-h(264 \DoveDisplay.SetCursorPosition 228 \SOFTCURSORPOSITION 118 \DoveMisc.SetMousePosition)
(252 \MACHINETYPE 243 \EM.CURSORY 234 \EM.CURSORX 220 \SOFTCURSORP 212 \EM.MOUSEY 203 \EM.MOUSEX 192 \IOPAGE 183 \IOPAGE 174 \IOPAGE 164 \IOPAGE 152 \IOPAGE 143 \IOPAGE 105 \MACHINETYPE 73 \MACHINETYPE 61 \CURSORHOTSPOTY 52 \CURSORDESTHEIGHT 44 \CURSORDESTHEIGHT 32 \CURSORHOTSPOTX 23 \CURSORDESTWIDTH 15 \CURSORDESTWIDTH 4 \CURSORDESTHEIGHT)
()
\CURSORDOWN :D8
(P 0 \INTERRUPTABLE) `�(19 \HARDCURSORDOWN 13 \SOFTCURSORDOWN)
(7 \SOFTCURSORP)
()
ADJUSTCURSORPOSITION :D8
(L (1 DELTAY 0 DELTAX)) �@d	�I�@``�dn��n���k���@`k�``�dn��n���k����
-�j``�dn��n���k���A�j`k�``�dn��n���k����
-(151 \CURSORPOSITION 78 \CURSORPOSITION 6 POSITIONP)
(129 \EM.CURSORY 124 \CURSORHOTSPOTY 117 \CURSORDESTHEIGHT 92 \EM.CURSORX 87 \CURSORHOTSPOTX 56 \EM.CURSORY 51 \CURSORHOTSPOTY 44 \CURSORDESTHEIGHT 21 \EM.CURSORX 16 \CURSORHOTSPOTX)
()
CURSORPOSITION :D8
(L (2 OLDPOSITION 1 DISPLAYSTREAM 0 NEWPOSITION)) �Agh�0XB�B3�
-Bd3��hdb``�dn��n���k��H
-B`k�``�dn��n���k���H
-@d�*d3�$d3�H��@H��
-�8�-@d��$�@d�d3�d3�@@�@�@	B(221 \ILLEGAL.ARG 212 CURSORSCREEN 165 \CURSORPOSITION 121 \DSPUNTRANSFORMY 80 \DSPUNTRANSFORMX 14 \GETSTREAM)
(178 SCREEN 157 \DISPLAYDATA 146 \DISPLAYDATA 99 \EM.CURSORY 94 \CURSORHOTSPOTY 87 \CURSORDESTHEIGHT 59 \EM.CURSORX 54 \CURSORHOTSPOTX 26 \DISPLAYDATA 19 STREAM 8 OUTPUT)
()
CURSORSCREEN :D8
(L (2 YCOORD 1 XCOORD 0 SCREEN) F 1 \CURSORSCREEN) :A�jb�B�jb�@�X@cH	`	AB
-h(54 \CURSORPOSITION 47 \CURSORUP 37 \CURSORDESTINATION 28 \CURSORDOWN)
(42 \CURRENTCURSOR 20 SCREEN)
()
CURSOREXIT :D8
(F 6 \MAINSCREEN F 7 \COLORSCREEN) b``X`Y`ZHV�W�V[Idj�d�lٍH�k��%k�JK�k��H�k��]KLMh(94 CURSORSCREEN)
(80 SCREEN 69 SCREEN 53 SCREEN 41 SCREEN 19 LASTMOUSEY 13 LASTMOUSEX 7 LASTSCREEN)
()
FLIPCURSOR :D8
NIL c`�X`�ldj�Hd�n�����Hkиkٰ�`dl��%l�!`d��`�}@h(58 \DoveDisplay.SetCursorShape)
(90 CURSOR 85 \CURRENTCURSOR 78 CURSOR 70 \CURRENTCURSOR 47 \MACHINETYPE 14 \EM.CURSORBITMAP 7 \SOFTCURSORP)
()
FLIPCURSORBAR :D8
(L (0 N)) T`�L`@�`@��n����`dl�l� `d��`�}@h(43 \DoveDisplay.SetCursorShape)
(74 CURSOR 69 \CURRENTCURSOR 62 CURSOR 54 \CURRENTCURSOR 33 \MACHINETYPE 18 \EM.CURSORBITMAP 11 \EM.CURSORBITMAP 4 \SOFTCURSORP)
()
LASTMOUSEX :D8
(L (0 DS)) $`@gh�0
-(33 \DSPUNTRANSFORMX 16 \GETSTREAM)
(28 \DISPLAYDATA 21 STREAM 10 OUTPUT 4 LASTMOUSEX)
()
LASTMOUSEY :D8
(L (0 DS)) $`@gh�0
-(33 \DSPUNTRANSFORMY 16 \GETSTREAM)
(28 \DISPLAYDATA 21 STREAM 10 OUTPUT 4 LASTMOUSEY)
()
CREATEPOSITION :D8
(L (1 YCOORD 0 XCOORD)) @�jA�jNIL
NIL
()
POSITIONP :D8
(L (0 X)) @�@3�	@3�@NIL
NIL
()
CURSORHOTSPOT :D8
(L (0 NEWPOSITION)) $``@	�@�@�(16 POSITIONP)
(32 \CURSORHOTSPOTY 24 \CURSORHOTSPOTX 9 \CURSORHOTSPOTY 4 \CURSORHOTSPOTX)
()
(PUTPROPS CURSORPROP ARGNAMES (NIL (CURSOR PROP {NEWVALUE}) . U))
(RPAQ? \CURSORHOTSPOTX 0)
(RPAQ? \CURSORHOTSPOTY 0)
(RPAQ? \CURRENTCURSOR NIL)
(RPAQ? \SOFTCURSORWIDTH NIL)
(RPAQ? \SOFTCURSORHEIGHT NIL)
(RPAQ? \SOFTCURSORP NIL)
(RPAQ? \SOFTCURSORUPP NIL)
(RPAQ? \SOFTCURSORUPBM NIL)
(RPAQ? \SOFTCURSORDOWNBM NIL)
(RPAQ? \SOFTCURSORBBT1 NIL)
(RPAQ? \SOFTCURSORBBT2 NIL)
(RPAQ? \SOFTCURSORBBT3 NIL)
(RPAQ? \SOFTCURSORBBT4 NIL)
(RPAQ? \SOFTCURSORBBT5 NIL)
(RPAQ? \SOFTCURSORBBT6 NIL)
(RPAQ? \CURSORSCREEN NIL)
(RPAQ? \CURSORDESTINATION NIL)
(RPAQ? \CURSORDESTHEIGHT 808)
(RPAQ? \CURSORDESTWIDTH 1024)
(RPAQ? \CURSORDESTRASTERWIDTH 64)
(RPAQ? \CURSORDESTLINE 0)
(RPAQ? \CURSORDESTLINEBASE NIL)
GETMOUSESTATE :D8
(F 0 \CURSORSCREEN) i``�dn��n���k��`k�``�dn��n���k���`�l�l�Ph(90 \EVENTKEYS)
(101 LASTSCREEN 95 LASTKEYBOARD 85 LASTMOUSEBUTTONS 72 \LASTKEYSTATE 67 LASTMOUSEY 46 \EM.CURSORY 41 \CURSORHOTSPOTY 34 \CURSORDESTHEIGHT 29 LASTMOUSEX 9 \EM.CURSORX 4 \CURSORHOTSPOTX)
()
\EVENTKEYS :D8
NIL �l�`l��j�j�kj�l��jl@`l��j�j�kj�l@�jl`l��j�j�kj�l �jl`l��j�j�kj�l�jk`l��j�j�kj�l�jl`l��j�j�kj�l�jl`l��j�j�kj�k�j������NIL
(149 \LASTKEYSTATE 125 \LASTKEYSTATE 101 \LASTKEYSTATE 78 \LASTKEYSTATE 54 \LASTKEYSTATE 30 \LASTKEYSTATE 6 \LASTKEYSTATE)
()
(RPAQQ HARDCURSORHEIGHT 16)
(RPAQQ HARDCURSORWIDTH 16)
(CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16))
(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD)
(MOVD (QUOTE CURSOR) (QUOTE SETCURSOR))
(MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION))
(RPAQ \SFPosition (CREATEPOSITION))
MACHINETYPE :D8
NIL 4`�
dl�gdl�gdl�gl�gNIL
(49 MAIKO 38 DOVE 27 DANDELION 16 DORADO 4 \InterfacePage)
()
SETMAINTPANEL :D8
(L (0 N)) 3`dl�`@�@dl�@xl�
-@9NIL
(46 SMALLP 32 SMALLP 15 \IOPAGE 4 \MACHINETYPE)
()
BEEPON :D8
(L (0 FREQ)) ]`dl�:�n�`��%`o@dl�l��+�`n��� ��dl�@	�l�i@}Ph(78 \DoveMisc.BeepOn 64 BLOCK)
(52 \IOPAGE 29 \IOPAGE 19 \IOPAGE 4 \MACHINETYPE)
( 34 1843200)
BEEPOFF :D8
NIL D`dl�"�n�`��`n�����dl��l�hd}Ph(53 \DoveMisc.BeepOff 40 BLOCK)
(28 \IOPAGE 19 \IOPAGE 4 \MACHINETYPE)
()
WITHOUT-INTERRUPTS :D8
(L (0 FORM)) @	XH(19 \KEYBOARDON 13 DISPLAYDOWN 7 \KEYBOARDOFF)
NIL
()
(PUTPROPS LLKEY FILETYPE CL:COMPILE-FILE)
(PUTPROPS LLKEY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 1990 
1992 1999 1920 2000))
NIL
\ No newline at end of file
diff --git a/sources/LLKEY.LCOM.~4~ b/sources/LLKEY.LCOM.~4~
deleted file mode 100644
index b2317868..00000000
Binary files a/sources/LLKEY.LCOM.~4~ and /dev/null differ
diff --git a/sources/LLKEY.~1~ b/sources/LLKEY.~1~
deleted file mode 100644
index 2ebf7636..00000000
--- a/sources/LLKEY.~1~
+++ /dev/null
@@ -1,1779 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED " 9-Apr-2000 16:28:23" {DSK}<tilde>sybalsky>lispcore>sources>LLKEY.;7 207701 
-
-      changes to%:  (FNS FLIPCURSORBAR FLIPCURSOR)
-
-      previous date%: "30-Mar-2000 20:01:05" {DSK}<tilde>sybalsky>lispcore>sources>LLKEY.;6)
-
-
-(* ; "
-Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992, 1999, 1920, 2000 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT LLKEYCOMS)
-
-(RPAQQ LLKEYCOMS 
-       [(COMS                                                (* ; "Access to keyboard")
-              (FNS BKSYSCHARCODE \CLEARSYSBUF \GETKEY \NSYSBUFCHARS \SAVESYSBUF \SYSBUFP \GETSYSBUF 
-                   \PUTSYSBUF \PEEKSYSBUF)
-              (INITVARS (\LONGSYSBUF))
-              (INITVARS (\\KEYBOARDWAITBOX.GLOBALRESOURCE))
-              (DECLARE%: DONTCOPY (RESOURCES \KEYBOARDWAITBOX))
-              (DECLARE%: DONTCOPY (CONSTANTS (\SYSBUFSIZE 200))
-                     (MACROS \GETREALSYSBUF)))
-        [DECLARE%: DOCOPY DONTEVAL@LOAD (COMS                (* ; 
-                                          "Here because it must be done in init before PROC loaded")
-                                              (P (MOVD? 'NILL 'CARET]
-        (COMS                                                (* ; "Key handler")
-              (FNS \KEYBOARDINIT \KEYBOARDEVENTFN \ALLOCLOCKED \SETIOPOINTERS \KEYBOARDOFF 
-                   \KEYBOARDON \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD \DOMOUSECHORDING 
-                   \DOTRANSITIONS \DECODETRANSITION MOUSECHORDWAIT \TRACKCURSOR)
-              (CONSTANTS (\SUN.TYPE3KEYBOARD 0)
-                     (\SUN.TYPE4KEYBOARD 1)
-                     (\SUN.JLEKEYBOARD 2)
-                     (\TOSHIBA.JIS 7))
-              (INITVARS (\MOUSECHORDTICKS)
-                     (\MOUSECHORDMILLISECONDS 50))
-              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\KEYBOARDINIT)))
-              [DECLARE%: DONTCOPY (MACROS .NOTELASTUSERACTION)
-                     (CONSTANTS ALLUP \CTRLMASK \METABIT)
-                     (CONSTANTS * DLMOUSEBITS)
-                     (CONSTANTS * DLMOUSESTATES)
-                     (CONSTANTS * TRANSITIONFLAGS)
-                     (MACROS \TRANSINDEX ARMEDCODE TRANSITIONALTGRCODE TRANSITIONSHIFTCODE 
-                            TRANSITIONCODE TRANSITIONFLAGS TRANSITIONDEADLIST CHECKFORDEADKEY)
-                     (EXPORT (RECORDS KEYACTION)
-                            (CONSTANTS \NKEYS))
-                     (RECORDS RING)
-                     (COMS                                   (* ; 
-                                          "can get rid of shiftstate after clients have been fixed")
-                           (RECORDS SHIFTSTATE)
-                           (GLOBALVARS \SHIFTSTATE \MOUSETIMERTEMP))
-                     (CONSTANTS NRINGINDEXWORDS)
-                     (CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
-                            (\SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE]
-              (DECLARE%: EVAL@COMPILE (VARS \KEYNAMES))
-              
-              (* ;; "\maikokeyactions does not contain keyactions of the form %"2,50%" because it breaks the loadup process on the sun.")
-
-              (VARS \ORIGKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DORADOKEYACTIONS 
-                    \DOVEKEYACTIONS \DOVEOSDKEYACTIONS \MAIKOKEYACTIONS \MAIKOKEYACTIONST4 
-                    \MAIKO-JLE-KEYACTIONS \TOSHIBA-KEYACTIONS)
-              (VARS (KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS NIL))
-              (INITVARS (\KEYBOARD.META 256)
-                     (\MODIFIED.KEYACTIONS))
-              (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS \RCLKSECOND \LASTUSERACTION \LASTKEYSTATE)
-                                             ))
-              (GLOBALVARS \SYSBUFFER \LONGSYSBUF \INTERRUPTSTATE \MODIFIED.KEYACTIONS 
-                     \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING \CURRENTKEYACTION 
-                     \COMMANDKEYACTION \DEFAULTKEYACTION \TIMER.INTERRUPT.PENDING \ORIGKEYACTIONS 
-                     \KEYBOARD.META \MOUSECHORDMILLISECONDS \DORADOKEYACTIONS \DLIONKEYACTIONS 
-                     \DLIONOSDKEYACTIONS \DOVEKEYACTIONS \DOVEOSDKEYACTIONS))
-        (COMS                                                (* ; "Key interpretation")
-              (FNS KEYACTION KEYACTIONTABLE KEYBOARDTYPE RESETKEYACTION 
-                   \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS \KEYACTION1 KEYDOWNP KEYNUMBERP 
-                   \KEYNAMETONUMBER MODIFY.KEYACTIONS METASHIFT SHIFTDOWNP)
-                                                             (* ; 
-                                                    "To support office style 1108 & 1186 keyboards")
-              (FNS SETUP.OFFICE.KEYBOARD)
-              (OPTIMIZERS \KEYNAMETONUMBER)
-              (MACROS \TEMPCOPYTIMER)
-                                                             (* ; 
-                  "Don't copy this optimizer since it expands out to \getbasebit, but do exportit.")
-              (DECLARE%: DONTCOPY (EXPORT (OPTIMIZERS KEYDOWNP)))
-              (EXPORT (MACROS XKEYDOWNP KEYDOWNP1 \NEWKEYDOWNP)))
-        (COMS                                                (* ; "A raw keyboard device/stream")
-              (FNS \INIT.KEYBOARD.STREAM)
-              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\INIT.KEYBOARD.STREAM)))
-              (EXPORT (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM)))
-        (COMS                                                (* ; "Hook for a periodic interrupt")
-              (FNS \DOBUFFEREDTRANSITIONS \TIMER.INTERRUPTFRAME \PERIODIC.INTERRUPTFRAME)
-              (INITVARS (\KEYBUFFERING)
-                     (\PERIODIC.INTERRUPT)
-                     (\TIMER.INTERRUPT.PENDING)
-                     (\PERIODIC.INTERRUPT.FREQUENCY 77)))
-        (LOCALVARS . T)
-        [COMS                                                (* ; 
-                                                           "cursor and mouse related functions.")
-              (FNS \HARDCURSORUP \HARDCURSORPOSITION \HARDCURSORDOWN)
-              (FNS CURSOR.INIT \CURSORDESTINATION \SOFTCURSORUP \SOFTCURSORUPCURRENT 
-                   \SOFTCURSORPOSITION \SOFTCURSORDOWN CURSORPROP GETCURSORPROP PUTCURSORPROP 
-                   \CURSORBITSPERPIXEL \CURSORIMAGEPROPNAME \CURSORMASKPROPNAME)
-              (FNS CURSORCREATE CURSOR \CURSOR-VALID-P \CURSORUP \CURSORPOSITION \CURSORDOWN 
-                   ADJUSTCURSORPOSITION CURSORPOSITION CURSORSCREEN CURSOREXIT FLIPCURSOR 
-                   FLIPCURSORBAR LASTMOUSEX LASTMOUSEY CREATEPOSITION POSITIONP CURSORHOTSPOT)
-              (PROPS (CURSORPROP ARGNAMES))
-              (INITVARS (\CURSORHOTSPOTX 0)
-                     (\CURSORHOTSPOTY 0)
-                     (\CURRENTCURSOR NIL)
-                     (\SOFTCURSORWIDTH NIL)
-                     (\SOFTCURSORHEIGHT NIL)
-                     (\SOFTCURSORP NIL)
-                     (\SOFTCURSORUPP NIL)
-                     (\SOFTCURSORUPBM NIL)
-                     (\SOFTCURSORDOWNBM NIL)
-                     (\SOFTCURSORBBT1 NIL)
-                     (\SOFTCURSORBBT2 NIL)
-                     (\SOFTCURSORBBT3 NIL)
-                     (\SOFTCURSORBBT4 NIL)
-                     (\SOFTCURSORBBT5 NIL)
-                     (\SOFTCURSORBBT6 NIL)
-                     (\CURSORSCREEN NIL)
-                     (\CURSORDESTINATION NIL)
-                     (\CURSORDESTHEIGHT 808)
-                     (\CURSORDESTWIDTH 1024)
-                     (\CURSORDESTRASTERWIDTH 64)
-                     (\CURSORDESTLINE 0)
-                     (\CURSORDESTLINEBASE NIL))
-              (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH 
-                     \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM
-                     \SOFTCURSORBBT1 \SOFTCURSORBBT2 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5
-                     \SOFTCURSORBBT6 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH 
-                     \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE)
-              (FNS GETMOUSESTATE \EVENTKEYS)
-              [EXPORT (CONSTANTS (HARDCURSORHEIGHT 16)
-                             (HARDCURSORWIDTH 16))
-                     (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN 
-                                                             LASTMOUSEBUTTONS LASTMOUSETIME 
-                                                             LASTKEYBOARD]
-              (DECLARE%: DONTCOPY (EXPORT (MACROS \SETMOUSEXY))
-                     (MACROS \XMOUSECOORD \YMOUSECOORD))
-              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'CURSOR 'SETCURSOR)
-                                                 (MOVD '\CURSORPOSITION '\SETCURSORPOSITION))
-                     (VARS (\SFPosition (CREATEPOSITION]
-        [COMS (DECLARE%: DONTCOPY (RECORDS KEYBOARDEVENT)
-                     (CONSTANTS (\KEYBOARDEVENT.FIRST NRINGINDEXWORDS)
-                            \KEYBOARDEVENT.SIZE
-                            (\KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES 
-                                                                                  \KEYBOARDEVENT.SIZE
-                                                                                   383]
-        (COMS (FNS MACHINETYPE SETMAINTPANEL)
-                                                             (* ; "DLion beeper")
-              (FNS BEEPON BEEPOFF))
-        (EXPORT (GLOBALVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN 
-                       \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 \EM.KBDAD5 
-                       \EM.DISPINTERRUPT \EM.DISPLAYHEAD \EM.CURSORBITMAP \MACHINETYPE 
-                       \DEFAULTKEYACTION \COMMANDKEYACTION \CURRENTKEYACTION \PERIODIC.INTERRUPT 
-                       \PERIODIC.INTERRUPT.FREQUENCY))
-        (FNS WITHOUT-INTERRUPTS)
-        (COMS                                                (* ; 
-                                                         "Compile locked fns together for locality")
-              (BLOCKS (NIL FLIPCURSORBAR \KEYHANDLER \KEYHANDLER1 \TRACKCURSOR 
-                           \PERIODIC.INTERRUPTFRAME \TIMER.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS 
-                           \DOTRANSITIONS \DECODETRANSITION \EVENTKEYS \HARDCURSORUP \DOMOUSECHORDING
-                           \KEYBOARDOFF \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP 
-                           \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN)))
-        [DECLARE%: DONTCOPY
-               (ADDVARS [INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS FLIPCURSORBAR \SETIOPOINTERS 
-                                                           \KEYHANDLER \KEYHANDLER1 \CONTEXTAPPLY 
-                                                           \LOCKPAGES \DECODETRANSITION \SMASHLINK 
-                                                           \INCUSECOUNT LLSH \MAKEFREEBLOCK 
-                                                           \DECUSECOUNT \MAKENUMBER \ADDBASE 
-                                                           \PERIODIC.INTERRUPTFRAME 
-                                                           \DOBUFFEREDTRANSITIONS 
-                                                           \TIMER.INTERRUPTFRAME \CAUSEINTERRUPT 
-                                                           \DOMOUSECHORDING \KEYBOARDOFF \TRACKCURSOR
-                                                           \HARDCURSORUP \HARDCURSORPOSITION 
-                                                           \HARDCURSORDOWN \SOFTCURSORUP 
-                                                           \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION 
-                                                           \SOFTCURSORDOWN \SOFTCURSORPILOTBITBLT)
-                                                  (LOCKEDVARS \InterfacePage \CURSORHOTSPOTX 
-                                                         \CURSORHOTSPOTY \CURRENTCURSOR 
-                                                         \SOFTCURSORWIDTH \SOFTCURSORHEIGHT 
-                                                         \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM
-                                                         \SOFTCURSORDOWNBM \SOFTCURSORBBT1 
-                                                         \SOFTCURSORBBT2 \SOFTCURSORBBT3 
-                                                         \SOFTCURSORBBT4 \SOFTCURSORBBT5 
-                                                         \SOFTCURSORBBT6 \CURSORDESTINATION 
-                                                         \CURSORDESTHEIGHT \CURSORDESTWIDTH 
-                                                         \CURSORDESTRASTERWIDTH \CURSORDESTLINE 
-                                                         \CURSORDESTLINEBASE \PENDINGINTERRUPT 
-                                                         \PERIODIC.INTERRUPT 
-                                                         \PERIODIC.INTERRUPT.FREQUENCY 
-                                                         \LASTUSERACTION \MOUSECHORDTICKS 
-                                                         \KEYBOARDEVENTQUEUE \KEYBUFFERING 
-                                                         SCREENWIDTH SCREENHEIGHT 
-                                                         \TIMER.INTERRUPT.PENDING \EM.MOUSEX 
-                                                         \EM.MOUSEY \EM.CURSORX \EM.CURSORY 
-                                                         \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0 
-                                                         \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 
-                                                         \EM.DISPINTERRUPT \EM.CURSORBITMAP 
-                                                         \EM.KBDAD4 \EM.KBDAD5 \MISCSTATS \RCLKSECOND
-                                                         ]
-                      (RDCOMS (FNS \SETIOPOINTERS]
-        (PROP FILETYPE LLKEY)
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML 
-                                                                                   WITHOUT-INTERRUPTS
-                                                                                    )
-                                                                             (LAMA CURSORPROP 
-                                                                                   METASHIFT 
-                                                                                   MOUSECHORDWAIT])
-
-
-
-(* ; "Access to keyboard")
-
-(DEFINEQ
-
-(BKSYSCHARCODE
  [LAMBDA (CHAR)                                         (* rrb "30-Dec-83 11:56")
    (OR (\PUTSYSBUF CHAR)
        (PROGN (SETQ \LONGSYSBUF (NCONC \LONGSYSBUF (bind C while (SETQ C (\GETREALSYSBUF))
                                                       collect C)))
               (\PUTSYSBUF CHAR])
-
-(\CLEARSYSBUF
  [LAMBDA (ALLFLG)                                       (* mpl "27-Jun-85 20:04")
    (DECLARE (GLOBALVARS \PROCESSES))
    (COND
       ((OR ALLFLG (TTY.PROCESSP))
        (SETQ \LONGSYSBUF)
        (replace (RING READ) of \SYSBUFFER with 0)))
    (COND
       (ALLFLG (for PROC in \PROCESSES do (replace PROCTYPEAHEAD of PROC
                                                         with NIL)))
       ((THIS.PROCESS)
        (replace PROCTYPEAHEAD of (THIS.PROCESS) with NIL])
-
-(\GETKEY
  [LAMBDA NIL                                            (* lmm "18-Apr-85 00:07")
    (DECLARE (GLOBALVARS \KEYBOARDWAIT1 \KEYBOARDWAIT2))
    (COND
       [(AND (THIS.PROCESS)
             (fetch PROCTYPEAHEAD of (THIS.PROCESS)))
        (pop (fetch PROCTYPEAHEAD of (THIS.PROCESS]
       (T (WAIT.FOR.TTY)
          (OR (\GETSYSBUF)
              (GLOBALRESOURCE (\KEYBOARDWAITBOX)             (* Busy-wait loop that gets next 
                                                           character)
                     (\CLOCK0 \KEYBOARDWAITBOX)
                     (bind C do (COND
                                           ((SETQ C (\GETSYSBUF))
                                            (\BOXIPLUS (LOCF (fetch KEYBOARDWAITTIME of
                                                                                         \MISCSTATS))
                                                   (CLOCKDIFFERENCE \KEYBOARDWAITBOX))
                                            (RETURN C)))
                                       (\TTYBACKGROUND)
                                       (\WAIT.FOR.TTY])
-
-(\NSYSBUFCHARS
  [LAMBDA NIL                                            (* JonL " 7-May-84 01:50")
          (* Tells how many characters can be \GETSYSBUFed.
        Used by \SAVESYSBUF.)

    (IPLUS (LENGTH \LONGSYSBUF)
           (PROG ((R (fetch (RING READ) of \SYSBUFFER))
                  (W (fetch (RING WRITE) of \SYSBUFFER)))
                 (RETURN (COND
                            ((EQ 0 R)
                             0)
                            ((IGREATERP W R)
                             (IDIFFERENCE W R))
                            (T (IDIFFERENCE W (IDIFFERENCE R \SYSBUFSIZE])
-
-(\SAVESYSBUF
  [LAMBDA NIL                                            (* JonL " 7-May-84 01:50")
    (DECLARE (GLOBALVARS \SAVEDSYSBUFFER))
    (PROG (TA (BUF \SAVEDSYSBUFFER)
              (NC (\NSYSBUFCHARS))
              (J 0))
          [COND
             ((TTY.PROCESSP)
              [COND
                 ([AND (THIS.PROCESS)
                       (SETQ TA (fetch PROCTYPEAHEAD of (THIS.PROCESS]
                  (replace PROCTYPEAHEAD of (THIS.PROCESS) with NIL)
                  (add NC (LENGTH TA))
                  [COND
                     ((IGREATERP NC (NCHARS BUF))
                      (SETQ BUF (ALLOCSTRING NC]
                  (for CH in TA do (RPLCHARCODE BUF (add J 1)
                                                      CH)))
                 ((IGREATERP NC (NCHARS BUF))
                  (SETQ BUF (ALLOCSTRING NC]
              (for I from (ADD1 J) to NC do 
          (* Test on J means that we'll ignore extra chars typed since we got the 
        length. Test on \GETSYSBUF so we don't get screwed if buffer gets cleared 
        while during this loop)

                                                           (RPLCHARCODE BUF I
                                                                  (OR (\GETSYSBUF)
                                                                      (PROGN (SETQ NC (SUB1 I))
                                                                             (RETURN]
          (RETURN (AND (NOT (EQ 0 NC))
                       (SUBSTRING BUF 1 NC])
-
-(\SYSBUFP
  [LAMBDA NIL                                            (* JonL " 7-May-84 01:52")
    (OR [AND (TTY.PROCESSP)
             (OR \LONGSYSBUF (NOT (EQ 0 (fetch (RING READ) of \SYSBUFFER]
        (AND (THIS.PROCESS)
             (fetch PROCTYPEAHEAD of (THIS.PROCESS])
-
-(\GETSYSBUF
  [LAMBDA NIL                                            (* lmm " 9-JUL-83 00:56")
    (OR (AND \LONGSYSBUF (pop \LONGSYSBUF))
        (\GETREALSYSBUF])
-
-(\PUTSYSBUF
  [LAMBDA (CHAR)                                         (* rmk%: "27-Nov-84 17:51")
    (PROG ((R (fetch (RING READ) of \SYSBUFFER))
           (W (fetch (RING WRITE) of \SYSBUFFER)))
          (RETURN (COND
                     ((EQ R W)                               (* Full)
                      NIL)
                     (T (\PUTBASEFAT \SYSBUFFER W CHAR)
                        (AND (EQ 0 R)
                             (replace (RING READ) of \SYSBUFFER with W))
                                                             (* Return random non-NIL value to 
                                                           indicate success for BKSYSBUF)
                        [replace (RING WRITE) of \SYSBUFFER with (COND
                                                                                ((EQ \SYSBUFFER.LAST 
                                                                                     W)
                                                                                 \SYSBUFFER.FIRST)
                                                                                (T (ADD1 W]
                        T])
-
-(\PEEKSYSBUF
  [LAMBDA (STREAM)                                       (* bvm%: " 8-Feb-85 17:50")
    (PROG (R)
      WAIT
          (until (\SYSBUFP) do (BLOCK))
          (RETURN (if (TTY.PROCESSP)
                      then (if \LONGSYSBUF
                                   then (CAR \LONGSYSBUF)
                                 elseif (NEQ (SETQ R (fetch (RING READ) of \SYSBUFFER))
                                                 0)
                                   then                  (* Here's the vanilla case)
                                         (\GETBASEFAT \SYSBUFFER R)
                                 else 
          (* Foo an interrupt could have sneaked in here and gobbled down the remaining 
        characters)

                                       (GO WAIT))
                    elseif (THIS.PROCESS)
                      then (CAR (fetch PROCTYPEAHEAD of (THIS.PROCESS)))
                    else (SHOULDNT])
-)
-
-(RPAQ? \LONGSYSBUF )
-
-(RPAQ? \\KEYBOARDWAITBOX.GLOBALRESOURCE )
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-[PUTDEF '\KEYBOARDWAITBOX 'RESOURCES '(NEW (CREATECELL \FIXP]
-)
-)
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \SYSBUFSIZE 200)
-
-
-(CONSTANTS (\SYSBUFSIZE 200))
-)
-
-(DECLARE%: EVAL@COMPILE 
-
-[PUTPROPS \GETREALSYSBUF MACRO
-       (NIL (PROG ((R (fetch (RING READ) of \SYSBUFFER)))
-                  (RETURN (AND (NOT (EQ 0 R))
-                               (PROG1 (\GETBASEFAT \SYSBUFFER R)
-                                   (AND [EQ (fetch (RING WRITE) of \SYSBUFFER)
-                                            (replace (RING READ) of \SYSBUFFER
-                                               with (COND
-                                                           ((EQ \SYSBUFFER.LAST R)
-                                                            \SYSBUFFER.FIRST)
-                                                           (T (ADD1 R]
-                                        (replace (RING READ) of \SYSBUFFER with 0)))]
-)
-)
-(DECLARE%: DOCOPY DONTEVAL@LOAD 
-
-
-
-(* ; "Here because it must be done in init before PROC loaded")
-
-
-(MOVD? 'NILL 'CARET)
-)
-
-
-
-(* ; "Key handler")
-
-(DEFINEQ
-
-(\KEYBOARDINIT
  [LAMBDA NIL                                            (* ; "Edited 19-Nov-87 16:46 by Snow")

    (DECLARE (GLOBALVARS \SAVEDSYSBUFFER))               (* ; 
                                                           "Sets up keyboard decoding tables.")

    (SETQ \CURRENTKEYACTION (SETQ \DEFAULTKEYACTION (KEYACTIONTABLE)))
                                                             (* ; 
                                                           "added \commandkeyaction 11-19-87 WAS")

    (SETQ \COMMANDKEYACTION (KEYACTIONTABLE))
    (SETQ \INTERRUPTSTATE (\ALLOCLOCKED 2))
    (PROGN (SETQ \SYSBUFFER (\ALLOCBLOCK (FOLDHI (ADD1 \SYSBUFFER.LAST)
                                                WORDSPERCELL)))
           (replace (RING READ) of \SYSBUFFER with 0)
           (replace (RING WRITE) of \SYSBUFFER with \SYSBUFFER.FIRST))
    (SETQ \SAVEDSYSBUFFER (ALLOCSTRING \SYSBUFSIZE NIL NIL T))
    (SETQ \LASTUSERACTION (LOCF (fetch LASTUSERACTION of \MISCSTATS)))
    (PROGN (SETQ \KEYBOARDEVENTQUEUE (\ALLOCLOCKED (FOLDHI (PLUS \KEYBOARDEVENT.LAST 
                                                                     \KEYBOARDEVENT.SIZE)
                                                              WORDSPERCELL)))
           (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0)
           (replace (RING WRITE) of \KEYBOARDEVENTQUEUE with \KEYBOARDEVENT.FIRST))
    (SETQ \LASTKEYSTATE (create KEYBOARDEVENT))
    (SETQ \SHIFTSTATE (create SHIFTSTATE))
    (SETQ \MOUSETIMERTEMP (SETUPTIMER 0 NIL 'TICKS))
    (MOUSECHORDWAIT \MOUSECHORDMILLISECONDS)
    (\KEYBOARDON])
-
-(\KEYBOARDEVENTFN
  [LAMBDA (FDEV EVENT EXTRA)                             (* ; "Edited 11-Oct-90 09:49 by jds")
    (DECLARE (GLOBALVARS \KEYBOARD.BEFORETYPE \DORADOKEYACTIONS \DLIONKEYACTIONS 
                        \MAIKO.BEFOREKEYTYPE))
    (SELECTQ EVENT
        ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) 
             (SETQ \KEYBOARD.BEFORETYPE \MACHINETYPE)
             (SETQ \MAIKO.BEFOREKEYTYPE (LOGAND 7 (FETCH (IFPAGE DEVCONFIG) OF \InterfacePage
                                                         )))
             (SETQ \MAIKO.XBEFORE? (SELECTQ (MACHINETYPE)
                                       (MAIKO (EQUAL "X" (UNIX-GETPARM "DISPLAY")))
                                       NIL)))
        ((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM)  (* ; 
    "Restarting a world.  If we changed machines, fix up the key actions to match the new machine.")
                                                             (* ; "(COND ((NEQ \\MACHINETYPE \\KEYBOARD.BEFORETYPE) ; Changed machines.  Change Keyactions. (|for| X |in| (\\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS) |do| (KEYACTION (CAR X) (CDR X) \\COMMANDKEYACTION) (KEYACTION (CAR X) (CDR X) \\DEFAULTKEYACTION)) (MOUSECHORDWAIT (MOUSECHORDWAIT))))")
             [COND
                ((OR (NEQ \MACHINETYPE \KEYBOARD.BEFORETYPE)
                     (NEQ \MAIKO.XBEFORE? (SELECTQ (MACHINETYPE)
                                              (MAIKO (EQUAL "X" (UNIX-GETPARM "DISPLAY")))
                                              NIL)))         (* ; 
                                                           "Changed machines.  Change Keyactions.")
                 [COND
                    ((NEQ (MACHINETYPE)
                          'MAIKO)

                     (* ;; "Non-SUN, so just change machine-specific key actions:")

                     (for X in (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS)
                        do (KEYACTION (CAR X)
                                      (CDR X)
                                      \COMMANDKEYACTION)
                              (KEYACTION (CAR X)
                                     (CDR X)
                                     \DEFAULTKEYACTION)))
                    (T 
                       (* ;; 
                     "On a SUN:  Some keyactions contradict %"normal%" ones, so reset them all.")

                       (for X in (APPEND \ORIGKEYACTIONS (
                                                              \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS
                                                                  )) do (KEYACTION
                                                                             (CAR X)
                                                                             (CDR X)
                                                                             \COMMANDKEYACTION)
                                                                           (KEYACTION
                                                                            (CAR X)
                                                                            (CDR X)
                                                                            \DEFAULTKEYACTION]
                 (MOUSECHORDWAIT (MOUSECHORDWAIT)))
                ((EQ (MACHINETYPE)
                     'MAIKO)

                 (* ;; "Same machine type.  SO only worry if we're on SUNs, where the keyboard type can differ between machines.")

                 (COND
                    ((NEQ \MAIKO.BEFOREKEYTYPE (LOGAND 7 (fetch (IFPAGE DEVCONFIG) of 
                                                                                       \InterfacePage
                                                                )))
                     (for X in (APPEND \ORIGKEYACTIONS (
                                                              \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS
                                                                )) do (KEYACTION (CAR X)
                                                                                 (CDR X)
                                                                                 \COMMANDKEYACTION)
                                                                         (KEYACTION (CAR X)
                                                                                (CDR X)
                                                                                \DEFAULTKEYACTION))
                     (MOUSECHORDWAIT (MOUSECHORDWAIT])
        NIL])
-
-(\ALLOCLOCKED
  [LAMBDA (NCELLS)                                       (* lmm "20-Apr-85 13:08")
                                                             (* allocate a block of NCELLS cells 
                                                           and lock it)
    (PROG [(BLOCK (\ALLOCBLOCK NCELLS NIL (IMIN NCELLS CELLSPERPAGE]
          (\LOCKCELL BLOCK (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BLOCK)
                                          (UNFOLD NCELLS WORDSPERCELL))
                                  WORDSPERPAGE))
          (RETURN BLOCK])
-
-(\SETIOPOINTERS
  [LAMBDA NIL                                         (* ; "Edited 28-Apr-88 01:10 by MASINTER")
    (SELECTC (SETTOPVAL '\MACHINETYPE (fetch MachineType of \InterfacePage))
        ((LIST \DOLPHIN \DORADO) 
             (SETTOPVAL '\EM.MOUSEX (EMADDRESS MOUSEX.EM))
             (SETTOPVAL '\EM.MOUSEY (EMADDRESS MOUSEY.EM))
             (SETTOPVAL '\EM.CURSORX (EMADDRESS CURSORX.EM))
             (SETTOPVAL '\EM.CURSORY (EMADDRESS CURSORY.EM))
             (SETTOPVAL '\EM.REALUTILIN (EMADDRESS UTILIN.EM))
             (SETTOPVAL '\EM.KBDAD0 (EMADDRESS KBDAD0.EM))
             (SETTOPVAL '\EM.KBDAD1 (EMADDRESS KBDAD1.EM))
             (SETTOPVAL '\EM.KBDAD2 (EMADDRESS KBDAD2.EM))
             (SETTOPVAL '\EM.KBDAD3 (EMADDRESS KBDAD3.EM))
             (SETTOPVAL '\EM.KBDAD4 (LOCF (fetch FAKEKBDAD4 of \InterfacePage)))
             (\PUTBASE \EM.KBDAD4 0 ALLUP)
             (SETTOPVAL '\EM.KBDAD5 (LOCF (fetch FAKEKBDAD5 OF \InterfacePage)))
             (\PUTBASE \EM.KBDAD5 0 ALLUP)
             (SETTOPVAL '\EM.DISPINTERRUPT (EMADDRESS DISPINTERRUPT.EM))
             (SETTOPVAL '\EM.CURSORBITMAP (EMADDRESS CURSORBITMAP.EM))
             (SETTOPVAL '\EM.DISPLAYHEAD (EMADDRESS DCB.EM))
             (SETTOPVAL 'SCREENWIDTH (UNFOLD (fetch ScreenWidth of \InterfacePage)
                                            BITSPERWORD)))
        ((LIST \DANDELION \MAIKO) 
             (SETTOPVAL '\EM.MOUSEX (fetch DLMOUSEXPTR of \IOPAGE))
             (SETTOPVAL '\EM.MOUSEY (fetch DLMOUSEYPTR of \IOPAGE))
             (SETTOPVAL '\EM.CURSORX (fetch DLCURSORXPTR of \IOPAGE))
             (SETTOPVAL '\EM.CURSORY (fetch DLCURSORYPTR of \IOPAGE))
             (PROGN (SETTOPVAL '\EM.REALUTILIN (fetch DLUTILINPTR of \IOPAGE))

                    (* ;; "Where the hardware bits live, vs.  where the Lisp software sees them after reinterpretation by keyhandler")

                    )
             (SETTOPVAL '\EM.KBDAD0 (fetch DLKBDAD0PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD1 (fetch DLKBDAD1PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD2 (fetch DLKBDAD2PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD3 (fetch DLKBDAD3PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD4 (fetch DLKBDAD4PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD5 (fetch DLKBDAD5PTR of \IOPAGE))
             (SETTOPVAL '\EM.DISPINTERRUPT (fetch DLDISPINTERRUPTPTR of \IOPAGE))
             (SETTOPVAL '\EM.CURSORBITMAP (fetch DLCURSORBITMAPPTR of \IOPAGE))
             (SETTOPVAL '\EM.DISPLAYHEAD NIL)
             (SETTOPVAL 'SCREENWIDTH (SELECTC \MACHINETYPE
                                         (\MAIKO (SUBRCALL DSP-SCREENWIDTH))
                                         1024)))
        (\DAYBREAK (PROG ((KBDBASE (\DoveMisc.GetKBDBase)))
                         (SETTOPVAL '\EM.KBDAD0 (\ADDBASE KBDBASE 1))
                         (SETTOPVAL '\EM.KBDAD1 (\ADDBASE KBDBASE 2))
                         (SETTOPVAL '\EM.KBDAD2 (\ADDBASE KBDBASE 3))
                         (SETTOPVAL '\EM.KBDAD3 (\ADDBASE KBDBASE 4))
                         (SETTOPVAL '\EM.KBDAD4 (\ADDBASE KBDBASE 5))
                         (SETTOPVAL '\EM.KBDAD5 (\ADDBASE KBDBASE 6))
                         (SETTOPVAL '\EM.MOUSEX (\DoveMisc.GetMouseXBase))
                         (SETTOPVAL '\EM.MOUSEY (\DoveMisc.GetMouseYBase))
                         (SETTOPVAL '\EM.CURSORBITMAP (\DoveDisplay.GetCursorBitmapBase))
                                                             (* These three set this way to 
                                                           prevent address faults)
                         (SETTOPVAL '\EM.DISPINTERRUPT (fetch DLDISPINTERRUPTPTR of \IOPAGE))
                         (SETTOPVAL '\EM.CURSORX (fetch DLCURSORXPTR of \IOPAGE))
                         (SETTOPVAL '\EM.CURSORY (fetch DLCURSORYPTR of \IOPAGE))
                         (PROGN (SETTOPVAL '\EM.REALUTILIN KBDBASE)

         (* Where the hardware bits live, vs. where the Lisp software sees them after 
       reinterpretation by keyhandler)

                                )
                         (SETTOPVAL 'SCREENWIDTH (\DoveDisplay.ScreenWidth))))
        (RAID))
    (SETTOPVAL '\EM.UTILIN (LOCF (fetch (IFPAGE FAKEMOUSEBITS) of \InterfacePage])
-
-(\KEYBOARDOFF
  [LAMBDA NIL                                         (* ; "Edited 20-Apr-88 10:28 by MASINTER")
    (\PUTBASE \EM.DISPINTERRUPT 0 (LOGAND (LOGXOR 65535 \LispKeyMask)
                                         (\GETBASE \EM.DISPINTERRUPT 0)))
    (COND
       ((EQ \MACHINETYPE \MAIKO)
        (SUBRCALL KEYBOARDSTATE NIL])
-
-(\KEYBOARDON
  [LAMBDA (NOCHECK)                                   (* ; "Edited 24-Apr-88 00:03 by MASINTER")
    (\SETIOPOINTERS)
    (\PUTBASE \EM.DISPINTERRUPT 0 (LOGOR \LispKeyMask (\GETBASE \EM.DISPINTERRUPT 0)))
    (COND
       ((EQ \MACHINETYPE \MAIKO)
        (SUBRCALL KEYBOARDSTATE T])
-
-(\KEYHANDLER
  [LAMBDA NIL                                            (* lmm "30-MAR-83 20:40")
    (\KEYHANDLER1])
-
-(\KEYHANDLER1
  [LAMBDA NIL                                            (* ; "Edited 30-Mar-88 10:40 by Snow")

    (PROG ((OLD0 ALLUP)
           (OLD1 ALLUP)
           (OLD2 ALLUP)
           (OLD3 ALLUP)
           (OLD4 ALLUP)
           (OLD5 ALLUP)
           (OLDU ALLUP)
           (OLDFAKEU ALLUP)
           (LOOPCNT 10)
           (PERIODCNT 60)
           (MOUSESTATE \DLMOUSE.UP)
           (MOUSETIMER (LOCF (fetch DLMOUSETIMER of \MISCSTATS)))
           (MOUSETEMP (LOCF (fetch DLMOUSETEMP of \MISCSTATS)))
           CURSORX CURSORY YHOT)
          (SETQ \KEYBUFFERING NIL)
          (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0)
      LP  (\CONTEXTSWITCH \KbdFXP)
          [COND
             (\PERIODIC.INTERRUPT                            (* eventually can be replaced with 
                                                           general timer mechanism)
                    (COND
                       ((IGREATERP PERIODCNT 0)              (* Continue counting down to zero)
                        (SETQ PERIODCNT (SUB1 PERIODCNT)))
                       ((\CAUSEINTERRUPT \KbdFXP (FUNCTION \PERIODIC.INTERRUPTFRAME))
          (* When we've counted down, then keep trying to cause the interrupt, and 
        reset the counter when it finally happens)

                        (SETQ PERIODCNT (SUB1 (OR \PERIODIC.INTERRUPT.FREQUENCY 1]
          [COND
             ((OR (NEQ (\GETBASE \EM.MOUSEX 0)
                       CURSORX)
                  (NEQ (\GETBASE \EM.MOUSEY 0)
                       CURSORY))
              (\TRACKCURSOR (SETQ CURSORX (\GETBASE \EM.MOUSEX 0))
                     (SETQ CURSORY (\GETBASE \EM.MOUSEY 0]
          [COND
             ((OR [COND
                     ((OR (NEQ OLDU (\GETBASE \EM.REALUTILIN 0))
                          (COND
                             ((AND (EQ MOUSESTATE \DLMOUSE.WAITING)
                                   (IGREATERP (\BOXIDIFFERENCE (\RCLK MOUSETEMP)
                                                     MOUSETIMER)
                                          0))
          (* Timer expired on seeing both left and right down, so set state to normal)

                              (SETQ MOUSESTATE \DLMOUSE.NORMAL)
                              T)))
                      (SETQ MOUSESTATE (\DOMOUSECHORDING (SETQ OLDU (\GETBASE \EM.REALUTILIN 0))
                                              MOUSESTATE))
                      (NEQ OLDFAKEU (\GETBASE \EM.UTILIN 0]
                  (NEQ OLD0 (\GETBASE \EM.KBDAD0 0))
                  (NEQ OLD1 (\GETBASE \EM.KBDAD1 0))
                  (NEQ OLD2 (\GETBASE \EM.KBDAD2 0))
                  (NEQ OLD3 (\GETBASE \EM.KBDAD3 0))
                  (NEQ OLD4 (\GETBASE \EM.KBDAD4 0))
                  (NEQ OLD5 (\GETBASE \EM.KBDAD5 0)))
              (COND
                 ((EQ 0 (LOGAND (\GETBASE \EM.KBDAD2 0)
                               2114))                        (* Ctrl-shift-DEL panic interrupt --
                                                           switch to TeleRaid immediately)
                  (swap (fetch (IFPAGE TELERAIDFXP) of \InterfacePage)
                         (fetch (IFPAGE KbdFXP) of \InterfacePage))
                  (\KEYBOARDOFF)
                  (SETQ OLD2 (\GETBASE \EM.KBDAD2 0))
                  (GO LP)))
              [PROG ((W (fetch (RING WRITE) of \KEYBOARDEVENTQUEUE))
                     (R (fetch (RING READ) of \KEYBOARDEVENTQUEUE))
                     WPTR)
                    (COND
                       ((EQ R W)                             (* eventqueue full!)
                        (RETURN)))
                    (SETQ WPTR (\ADDBASE \KEYBOARDEVENTQUEUE W))
                    (\RCLK (LOCF (fetch TIME of WPTR)))
                    [with KEYBOARDEVENT WPTR (PROGN (SETQ W0 (SETQ OLD0 (\GETBASE \EM.KBDAD0 0)))
                                                        (SETQ W1 (SETQ OLD1 (\GETBASE \EM.KBDAD1 0)))
                                                        (SETQ W2 (SETQ OLD2 (\GETBASE \EM.KBDAD2 0)))
                                                        (SETQ W3 (SETQ OLD3 (\GETBASE \EM.KBDAD3 0)))
                                                        (SETQ W4 (SETQ OLD4 (\GETBASE \EM.KBDAD4 0)))
                                                        (SETQ W5 (SETQ OLD5 (\GETBASE \EM.KBDAD5 0)))
                                                        (SETQ WU (SETQ OLDFAKEU (\GETBASE \EM.UTILIN 
                                                                                       0]
                    (COND
                       ((EQ R 0)                             (* Queue was empty)
                        (replace (RING READ) of \KEYBOARDEVENTQUEUE with W)))
                    (replace (RING WRITE) of \KEYBOARDEVENTQUEUE
                       with (COND
                                   ((IGEQ W \KEYBOARDEVENT.LAST)
                                    \KEYBOARDEVENT.FIRST)
                                   (T (IPLUS W \KEYBOARDEVENT.SIZE]
              (OR \KEYBUFFERING (SETQ \KEYBUFFERING T]
          [COND
             [\KEYBUFFERING (COND
                               ((EQ \KEYBUFFERING T)
                                (COND
                                   ((\CAUSEINTERRUPT \KbdFXP (FUNCTION \DOBUFFEREDTRANSITIONS))
                                    (SETQ \KEYBUFFERING 'STARTED)
                                                             (* don't call until 
                                                           \DOBUFFEREDTRANSITIONS is done)
                                    ]
             (T (COND
                   (\PENDINGINTERRUPT (COND
                                         ((\CAUSEINTERRUPT \KbdFXP (FUNCTION \INTERRUPTFRAME))
                                          (SETQ \PENDINGINTERRUPT]
          [COND
             ((AND (NEQ \MACHINETYPE \MAIKO)
                   (ILEQ (SETQ LOOPCNT (SUB1 LOOPCNT))
                         0))                                 (* Only do this once in a while)
              (SETQ LOOPCNT (COND
                               ((\UPDATETIMERS)
          (* Timer was updated, so do it next time around, too, in case we just came 
        back from RAID or other bcpl code)

                                1)
                               (T 20]
          (COND
             ([AND NIL \TIMER.INTERRUPT.PENDING (IGREATERP (\BOXIDIFFERENCE
                                                            (\RCLK (LOCF (fetch DLMOUSETEMP
                                                                            of \MISCSTATS)))
                                                            (LOCF (fetch DLMOUSETIMER
                                                                     of \MISCSTATS)))
                                                       0)
                   (COND
                      ((EQ \TIMER.INTERRUPT.PENDING '\MOUSECHANGE)
                       (SETQ OLDU NIL)
                       T)
                      (T (\CAUSEINTERRUPT \KbdFXP (FUNCTION \TIMER.INTERRUPTFRAME]
              (SETQ \TIMER.INTERRUPT.PENDING)))
          (GO LP])
-
-(\RESETKEYBOARD
  [LAMBDA NIL                                            (* ; "Edited 30-Mar-88 10:07 by Snow")

    (\SETIOPOINTERS)
          (* Called with lisp keyboard disabled whenever Lisp is resumed from bcpl 
        logout or copysys.)

    (SETQ \KEYBUFFERING NIL)
    (COND
       ((OR (EQ \MACHINETYPE \DANDELION)
            (EQ \MACHINETYPE \DAYBREAK)
            (EQ \MACHINETYPE \MAIKO))                        (* Initialize fake mouse bits to all 
                                                           up)
        (\PUTBASE \EM.UTILIN 0 ALLUP)))
    (with KEYBOARDEVENT \LASTKEYSTATE (SETQ W0 (\GETBASE \EM.KBDAD0 0))
           (SETQ W1 (\GETBASE \EM.KBDAD1 0))
           (SETQ W2 (\GETBASE \EM.KBDAD2 0))
           (SETQ W3 (\GETBASE \EM.KBDAD3 0))
           (SETQ W4 (\GETBASE \EM.KBDAD4 0))
           (SETQ W5 (\GETBASE \EM.KBDAD5 0))
           (SETQ WU (\GETBASE \EM.REALUTILIN 0))
           (SETQ LOCK (XKEYDOWNP 'LOCK))
           (SETQ 1SHIFT NIL)
           (SETQ 2SHIFT NIL)
           (SETQ CTRL NIL)
           (SETQ META NIL)
           (SETQ FONT NIL)
           (SETQ USERMODE1 NIL)
           (SETQ USERMODE2 NIL)
           (SETQ USERMODE3 NIL)
           (SETQ MOUSESTATE \DLMOUSE.UP))
    (SETQ \TIMER.INTERRUPT.PENDING)
    (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0)
    (replace (RING READ) of \SYSBUFFER with 0)
    (SETQ \LONGSYSBUF)
    (\DAYTIME0 \LASTUSERACTION)
    (\KEYBOARDON])
-
-(\DOMOUSECHORDING
  [LAMBDA (REALUTILIN STATE)                             (* bvm%: " 9-Oct-85 11:24")
          (* Handles mouse transitions on a DLion.
        REALUTILIN is the actual util word from the processor.
        STATE is our internal state. Sets contents of \EM.UTILIN to reflect the 
        virtual mouse state, which may contain a middle mouse button even where there 
        is only a two-button mouse. Returns new state)

    (PROG (LRSTATE)
          [COND
             ((OR (NULL \MOUSECHORDTICKS)
                  (EQ (SETQ LRSTATE (LOGXOR (LOGAND REALUTILIN \MOUSE.ALLBITS)
                                           \MOUSE.ALLBITS))
                      0))
          (* Not interpreting chording, or both LEFT and RIGHT are up --
        real state and virtual state the same)

              (SETQ STATE \DLMOUSE.UP))
             (T 
          (* Either L or R or both are down, so have to decide about Middle)

                (SELECTC STATE
                    ((LIST \DLMOUSE.UP \DLMOUSE.WAITING) 
                         (SETQ REALUTILIN (LOGOR REALUTILIN \MOUSE.LRBIT))
                                                             (* Turn off the L and/or R bits)
                         (COND
                            ((EQ LRSTATE \MOUSE.LRBIT)
          (* Both L and R down at once, interpret as MIDDLE without waiting)

                             (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT)
                                                     REALUTILIN))
                             (SETQ STATE \DLMOUSE.MIDDLE))
                            ((NEQ STATE \DLMOUSE.WAITING)
          (* Only one of L and R down. Set timer, and ignore the down bit for now)

                             (\BOXIPLUS (\RCLK (LOCF (fetch DLMOUSETIMER of \MISCSTATS)))
                                    \MOUSECHORDTICKS)
                             (SETQ STATE \DLMOUSE.WAITING))))
                    (\DLMOUSE.MIDDLE 
          (* State is middle and at least one of L and R is still down, so consider it 
        to be still only middle)

                         (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT)
                                                 (LOGOR REALUTILIN \MOUSE.LRBIT)))
                         (SELECTC LRSTATE
                             (\MOUSE.LEFTBIT                 (* Right came up. Henceforth treat 
                                                           right transparently)
                                  (SETQ STATE \DLMOUSE.MIDDLE&RIGHT))
                             (\MOUSE.RIGHTBIT                (* Left came up. Henceforth treat 
                                                           left transparently)
                                  (SETQ STATE \DLMOUSE.MIDDLE&LEFT))
                             NIL))
                    (\DLMOUSE.MIDDLE&RIGHT                   (* Only ignore LEFT)
                         (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT)
                                                 (LOGOR REALUTILIN \MOUSE.LEFTBIT))))
                    (\DLMOUSE.MIDDLE&LEFT                    (* Only ignore RIGHT)
                         (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT)
                                                 (LOGOR REALUTILIN \MOUSE.RIGHTBIT))))
                    (PROGN 
          (* Remaining state is \DLMOUSE.NORMAL which means treat mouse normally, and 
        the only interesting transition is back to \DLMOUSE.UP)
]
          (\PUTBASE \EM.UTILIN 0 REALUTILIN)
          (RETURN STATE])
-
-(\DOTRANSITIONS
  [LAMBDA (KEYBASE OLD NEW)                              (* ; "Edited  1-Feb-92 11:59 by jds")

    (* ;; "OLD and NEW are keyboard state words that are known to have changed.  KEYBASE is the number in hardware order of the key corresponding to the first bit in these words.  This function figures out the indices of transitioning keys and calls the decoder.")

    (for I (BITMASK _ (LLSH 1 15)) from 0 to 15
       do [OR (EQ 0 (LOGAND BITMASK (LOGXOR OLD NEW)))
                  (\DECODETRANSITION (IPLUS I KEYBASE)
                         (EQ 0 (LOGAND NEW BITMASK]
             (SETQ BITMASK (LRSH BITMASK 1)))
    T])
-
-(\DECODETRANSITION
  [LAMBDA (KEYNUMBER DOWNFLG)                                (* ; "Edited 19-Nov-87 16:29 by Snow")

    (* ;; "KEYNUMBER is the key number in the hardware keyboard layout, DOWNFLG is T if the key just went down.  PENDINGINTERRUPT, bound in \KEYHANDLER, is set to the decoded character if it is an interrupt.")

    (.NOTELASTUSERACTION)
    (PROG ((TI (\TRANSINDEX KEYNUMBER DOWNFLG))
           (KEYSTATE \LASTKEYSTATE)
           ASCIICODE SHIFTED)
          (SELECTC (TRANSITIONFLAGS \CURRENTKEYACTION TI)
              (IGNORE.TF (RETURN))
              (LOCKSHIFT.TF                                  (* ; 
                                           "Take shift action if either Shift or Caps Lock is down")
                            (IF (fetch (KEYBOARDEVENT SHIFTORLOCK) of KEYSTATE)
                                THEN (SETQ SHIFTED T)))
              (NOLOCKSHIFT.TF                                (* ; 
                                                        "Take shift action only when Shift is down")
                   (IF (fetch (KEYBOARDEVENT SHIFT) of KEYSTATE)
                       THEN (SETQ SHIFTED T)))
              (EVENT.TF (RETURN))
              (1SHIFTUP.TF (replace (KEYBOARDEVENT 1SHIFT) of KEYSTATE with NIL)
                           (RETURN))
              (1SHIFTDOWN.TF (replace (KEYBOARDEVENT 1SHIFT) of KEYSTATE with T)
                             (RETURN))
              (2SHIFTUP.TF (replace (KEYBOARDEVENT 2SHIFT) of KEYSTATE with NIL)
                           (RETURN))
              (2SHIFTDOWN.TF (replace (KEYBOARDEVENT 2SHIFT) of KEYSTATE with T)
                             (RETURN))
              (LOCKUP.TF (replace (KEYBOARDEVENT LOCK) of KEYSTATE with NIL)
                         (RETURN))
              (LOCKDOWN.TF (replace (KEYBOARDEVENT LOCK) of KEYSTATE with T)
                           (RETURN))
              (LOCKTOGGLE.TF (replace (KEYBOARDEVENT LOCK) of KEYSTATE
                                with (NOT (fetch (KEYBOARDEVENT LOCK) of KEYSTATE)))
                             (RETURN))
              (CTRLUP.TF (replace (KEYBOARDEVENT CTRL) of KEYSTATE with NIL)
                         (RETURN))
              (CTRLDOWN.TF (replace (KEYBOARDEVENT CTRL) of KEYSTATE with T)
                           (RETURN))
              (METAUP.TF (replace (KEYBOARDEVENT META) of KEYSTATE with NIL)
                         (RETURN))
              (METADOWN.TF (replace (KEYBOARDEVENT META) of KEYSTATE with T)
                           (RETURN))
              (FONTUP.TF (replace (KEYBOARDEVENT FONT) of KEYSTATE with NIL)
                         (RETURN))
              (FONTDOWN.TF (replace (KEYBOARDEVENT FONT) of KEYSTATE with T)
                           (RETURN))
              (FONTTOGGLE.TF (replace (KEYBOARDEVENT FONT) of KEYSTATE
                                with (NOT (fetch (KEYBOARDEVENT FONT) of KEYSTATE)))
                             (RETURN))
              (USERMODE1UP.TF 
                   (replace (KEYBOARDEVENT USERMODE1) of KEYSTATE with NIL)
                   (RETURN))
              (USERMODE1DOWN.TF 
                   (replace (KEYBOARDEVENT USERMODE1) of KEYSTATE with T)
                   (RETURN))
              (USERMODE1TOGGLE.TF 
                   (replace (KEYBOARDEVENT USERMODE1) of KEYSTATE
                      with (NOT (fetch (KEYBOARDEVENT USERMODE1) of KEYSTATE)))
                   (RETURN))
              (USERMODE2UP.TF 
                   (replace (KEYBOARDEVENT USERMODE2) of KEYSTATE with NIL)
                   (RETURN))
              (USERMODE2DOWN.TF 
                   (replace (KEYBOARDEVENT USERMODE2) of KEYSTATE with T)
                   (RETURN))
              (USERMODE2TOGGLE.TF 
                   (replace (KEYBOARDEVENT USERMODE2) of KEYSTATE
                      with (NOT (fetch (KEYBOARDEVENT USERMODE2) of KEYSTATE)))
                   (RETURN))
              (USERMODE3UP.TF 
                   (replace (KEYBOARDEVENT USERMODE3) of KEYSTATE with NIL)
                   (RETURN))
              (USERMODE3DOWN.TF 
                   (replace (KEYBOARDEVENT USERMODE3) of KEYSTATE with T)
                   (RETURN))
              (USERMODE3TOGGLE.TF 
                   (replace (KEYBOARDEVENT USERMODE3) of KEYSTATE
                      with (NOT (fetch (KEYBOARDEVENT USERMODE3) of KEYSTATE)))
                   (RETURN))
              (SHOULDNT))

     (* ;; 
   "Only the LOCKSHIFT and NOLOCKSHIFT cases make it to here, having set SHIFTED if appropriate.")

          [SETQ ASCIICODE (COND
                             (SHIFTED (TRANSITIONSHIFTCODE \CURRENTKEYACTION TI))
                             (T (TRANSITIONCODE \CURRENTKEYACTION TI]
          [COND
             ((OR (fetch (KEYBOARDEVENT CTRL) of KEYSTATE)
                  (fetch (KEYBOARDEVENT META) of KEYSTATE)
                  (fetch (KEYBOARDEVENT FONT) of KEYSTATE))
              [IF (IGREATERP ASCIICODE 127)
                  THEN 

                        (* ;; "Non-ascii interpretation--what is cntrl/meta supposed to mean?  Try using the original interpretation.  This way we can type ^E or Meta-D even if Russian keyboard is set, but doesn't mess up simple ascii remappings, such as bs->del.")

                        (SETQ ASCIICODE (COND
                                           (SHIFTED (TRANSITIONSHIFTCODE \COMMANDKEYACTION TI))
                                           (T (TRANSITIONCODE \COMMANDKEYACTION TI]
              [COND
                 ((fetch (KEYBOARDEVENT CTRL) of KEYSTATE)
                  (SETQ ASCIICODE (LOGAND ASCIICODE \CTRLMASK]
              (COND
                 ((AND (OR (fetch (KEYBOARDEVENT META) of KEYSTATE)
                           (fetch (KEYBOARDEVENT FONT) of KEYSTATE))
                       (ILESSP ASCIICODE \KEYBOARD.META))
                  (SETQ ASCIICODE (LOGOR ASCIICODE \KEYBOARD.META]
          (COND
             ((ASSOC ASCIICODE (fetch INTERRUPTLIST of \CURRENTKEYACTION))
              (SETQ PENDINGINTERRUPT T)
              (replace WAITINGINTERRUPT of \INTERRUPTSTATE with T)
              (replace INTCHARCODE of \INTERRUPTSTATE with ASCIICODE))
             (T (\PUTSYSBUF ASCIICODE])
-
-(MOUSECHORDWAIT
  [LAMBDA MSECS                                          (* MPL "21-Jun-85 16:31")
    (DECLARE (GLOBALVARS \RCLKMILLISECOND))
    (PROG1 (AND \MOUSECHORDTICKS \MOUSECHORDMILLISECONDS)
           (COND
              ((IGREATERP MSECS 0)
               (SETQ \MOUSECHORDTICKS (AND (ARG MSECS 1)
                                           (IMIN MAX.SMALLP (ITIMES (SETQ \MOUSECHORDMILLISECONDS
                                                                     (OR (SMALLP (ARG MSECS 1))
                                                                         50))
                                                                   \RCLKMILLISECOND])
-
-(\TRACKCURSOR
  [LAMBDA (CURSORX CURSORY)                              (* ; "Edited 30-Mar-88 11:11 by Snow")

    (DECLARE (GLOBALVARS \CURSORDESTHEIGHT \CURSORDESTWIDTH))
    (.NOTELASTUSERACTION)
    [COND
       ((OR [COND
               ((IGEQ CURSORX (IDIFFERENCE \CURSORDESTWIDTH \CURSORHOTSPOTX))
          (* Large cursor values are either out of bounds to the right or are negative 
        values (16-bit bcpl signed numbers))

                (COND
                   [(IGREATERP CURSORX 32767)                (* Cursor value is negative)
                    (COND
                       ((ILESSP (IPLUS (SUB1 (IDIFFERENCE CURSORX 65535))
                                       \CURSORHOTSPOTX)
                               0)
          (* Cursor pos + hotspot is still off to the left
        (the IPLUS is an optimization of (\XMOUSECOORD))%, so clip to effective zero)

                        (SETQ CURSORX (COND
                                         ((EQ \MACHINETYPE \DANDELION)
                                                             (* Temporary workaround)
                                          0)
                                         (T (UNSIGNED (IMINUS \CURSORHOTSPOTX)
                                                   BITSPERWORD]
                   (T (SETQ CURSORX (SUB1 (IDIFFERENCE \CURSORDESTWIDTH \CURSORHOTSPOTX]
            (IGEQ CURSORY (IDIFFERENCE \CURSORDESTHEIGHT HARDCURSORHEIGHT)))
          (* repeat test so that both X and Y will get clipped each cycle.
        This keeps the cursor from moving off the screen.)

        [COND
           ((IGEQ CURSORY (IDIFFERENCE \CURSORDESTHEIGHT \CURSORHOTSPOTY))
          (* Large cursor values are either out of bounds to the bottom or are negative 
        values (16-bit bcpl signed numbers))

            (COND
               [(IGREATERP CURSORY 32767)                    (* Cursor value is negative)
                (COND
                   ((ILESSP (IPLUS (SUB1 (IDIFFERENCE CURSORY 65535))
                                   \CURSORHOTSPOTY)
                           0)
          (* Cursor pos + hotspot is still off to the top, so clip to effective zero)

                    (SETQ CURSORY (COND
                                     ((OR (EQ \MACHINETYPE \DANDELION)
                                          (EQ \MACHINETYPE \DAYBREAK))
                                                             (* Temporary workaround)
                                      0)
                                     (T (UNSIGNED (IMINUS \CURSORHOTSPOTY)
                                               BITSPERWORD]
               (T (SETQ CURSORY (SUB1 (IDIFFERENCE \CURSORDESTHEIGHT \CURSORHOTSPOTY]
          (* If need to clip mouse, do so here. \SETMOUSEXY MACRO takes dlion 
        complexities into account.)

        (COND
           ((NEQ \MACHINETYPE \MAIKO)
            (\SETMOUSEXY CURSORX CURSORY]
    (COND
       (\SOFTCURSORUPP (\SOFTCURSORPOSITION CURSORX CURSORY)))
    (COND
       ((EQ \MACHINETYPE \DAYBREAK)
          (* Have to kick DAYBREAK IOP to track the cursor.
        *)

        (\DoveDisplay.SetCursorPosition CURSORX CURSORY)))
    (\PUTBASE \EM.CURSORX 0 CURSORX)
    (\PUTBASE \EM.CURSORY 0 CURSORY])
-)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \SUN.TYPE3KEYBOARD 0)
-
-(RPAQQ \SUN.TYPE4KEYBOARD 1)
-
-(RPAQQ \SUN.JLEKEYBOARD 2)
-
-(RPAQQ \TOSHIBA.JIS 7)
-
-
-(CONSTANTS (\SUN.TYPE3KEYBOARD 0)
-       (\SUN.TYPE4KEYBOARD 1)
-       (\SUN.JLEKEYBOARD 2)
-       (\TOSHIBA.JIS 7))
-)
-
-(RPAQ? \MOUSECHORDTICKS )
-
-(RPAQ? \MOUSECHORDMILLISECONDS 50)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(\KEYBOARDINIT)
-)
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS .NOTELASTUSERACTION MACRO (NIL (\BLT \LASTUSERACTION (LOCF (fetch SECONDSTMP
-                                                                        of \MISCSTATS))
-                                               WORDSPERCELL)))
-)
-
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ ALLUP 65535)
-
-(RPAQQ \CTRLMASK 159)
-
-(RPAQQ \METABIT 128)
-
-
-(CONSTANTS ALLUP \CTRLMASK \METABIT)
-)
-
-
-(RPAQQ DLMOUSEBITS ((\MOUSE.LEFTBIT 4)
-                        (\MOUSE.RIGHTBIT 2)
-                        (\MOUSE.MIDDLEBIT 1)
-                        (\MOUSE.ALLBITS 7)
-                        (\MOUSE.LRBIT 6)))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \MOUSE.LEFTBIT 4)
-
-(RPAQQ \MOUSE.RIGHTBIT 2)
-
-(RPAQQ \MOUSE.MIDDLEBIT 1)
-
-(RPAQQ \MOUSE.ALLBITS 7)
-
-(RPAQQ \MOUSE.LRBIT 6)
-
-
-(CONSTANTS (\MOUSE.LEFTBIT 4)
-       (\MOUSE.RIGHTBIT 2)
-       (\MOUSE.MIDDLEBIT 1)
-       (\MOUSE.ALLBITS 7)
-       (\MOUSE.LRBIT 6))
-)
-
-
-(RPAQQ DLMOUSESTATES ((\DLMOUSE.UP 0)
-                          (\DLMOUSE.WAITING 1)
-                          (\DLMOUSE.NORMAL 2)
-                          (\DLMOUSE.MIDDLE 3)
-                          (\DLMOUSE.MIDDLE&LEFT 4)
-                          (\DLMOUSE.MIDDLE&RIGHT 5)))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \DLMOUSE.UP 0)
-
-(RPAQQ \DLMOUSE.WAITING 1)
-
-(RPAQQ \DLMOUSE.NORMAL 2)
-
-(RPAQQ \DLMOUSE.MIDDLE 3)
-
-(RPAQQ \DLMOUSE.MIDDLE&LEFT 4)
-
-(RPAQQ \DLMOUSE.MIDDLE&RIGHT 5)
-
-
-(CONSTANTS (\DLMOUSE.UP 0)
-       (\DLMOUSE.WAITING 1)
-       (\DLMOUSE.NORMAL 2)
-       (\DLMOUSE.MIDDLE 3)
-       (\DLMOUSE.MIDDLE&LEFT 4)
-       (\DLMOUSE.MIDDLE&RIGHT 5))
-)
-
-
-(RPAQQ TRANSITIONFLAGS 
-       (ALTGRDOWN.TF ALTGRUP.TF ALTGRTOGGLE.TF CTRLDOWN.TF CTRLUP.TF DEADKEY.TF IGNORE.TF EVENT.TF 
-              LOCKDOWN.TF LOCKSHIFT.TF LOCKTOGGLE.TF LOCKUP.TF NOLOCKSHIFT.TF 1SHIFTDOWN.TF 
-              1SHIFTUP.TF 2SHIFTDOWN.TF 2SHIFTUP.TF METADOWN.TF METAUP.TF FONTDOWN.TF FONTUP.TF 
-              FONTTOGGLE.TF USERMODE1UP.TF USERMODE1DOWN.TF USERMODE1TOGGLE.TF USERMODE2UP.TF 
-              USERMODE2DOWN.TF USERMODE2TOGGLE.TF USERMODE3UP.TF USERMODE3DOWN.TF USERMODE3TOGGLE.TF))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ ALTGRDOWN.TF 27)
-
-(RPAQQ ALTGRUP.TF 28)
-
-(RPAQQ ALTGRTOGGLE.TF 29)
-
-(RPAQQ CTRLDOWN.TF 5)
-
-(RPAQQ CTRLUP.TF 4)
-
-(RPAQQ DEADKEY.TF 30)
-
-(RPAQQ IGNORE.TF 0)
-
-(RPAQQ EVENT.TF 1)
-
-(RPAQQ LOCKDOWN.TF 8)
-
-(RPAQQ LOCKSHIFT.TF 2)
-
-(RPAQQ LOCKTOGGLE.TF 14)
-
-(RPAQQ LOCKUP.TF 7)
-
-(RPAQQ NOLOCKSHIFT.TF 3)
-
-(RPAQQ 1SHIFTDOWN.TF 6)
-
-(RPAQQ 1SHIFTUP.TF 9)
-
-(RPAQQ 2SHIFTDOWN.TF 11)
-
-(RPAQQ 2SHIFTUP.TF 10)
-
-(RPAQQ METADOWN.TF 13)
-
-(RPAQQ METAUP.TF 12)
-
-(RPAQQ FONTDOWN.TF 24)
-
-(RPAQQ FONTUP.TF 25)
-
-(RPAQQ FONTTOGGLE.TF 26)
-
-(RPAQQ USERMODE1UP.TF 15)
-
-(RPAQQ USERMODE1DOWN.TF 16)
-
-(RPAQQ USERMODE1TOGGLE.TF 17)
-
-(RPAQQ USERMODE2UP.TF 18)
-
-(RPAQQ USERMODE2DOWN.TF 19)
-
-(RPAQQ USERMODE2TOGGLE.TF 20)
-
-(RPAQQ USERMODE3UP.TF 21)
-
-(RPAQQ USERMODE3DOWN.TF 22)
-
-(RPAQQ USERMODE3TOGGLE.TF 23)
-
-
-(CONSTANTS ALTGRDOWN.TF ALTGRUP.TF ALTGRTOGGLE.TF CTRLDOWN.TF CTRLUP.TF DEADKEY.TF IGNORE.TF EVENT.TF
-       LOCKDOWN.TF LOCKSHIFT.TF LOCKTOGGLE.TF LOCKUP.TF NOLOCKSHIFT.TF 1SHIFTDOWN.TF 1SHIFTUP.TF 
-       2SHIFTDOWN.TF 2SHIFTUP.TF METADOWN.TF METAUP.TF FONTDOWN.TF FONTUP.TF FONTTOGGLE.TF 
-       USERMODE1UP.TF USERMODE1DOWN.TF USERMODE1TOGGLE.TF USERMODE2UP.TF USERMODE2DOWN.TF 
-       USERMODE2TOGGLE.TF USERMODE3UP.TF USERMODE3DOWN.TF USERMODE3TOGGLE.TF)
-)
-
-(DECLARE%: EVAL@COMPILE 
-
-[PUTPROPS \TRANSINDEX MACRO ((KEYNUMBER DOWNFLG)
-                             (COND
-                                (DOWNFLG (IPLUS \NKEYS KEYNUMBER))
-                                (T KEYNUMBER]
-
-(PUTPROPS ARMEDCODE MACRO ((TABLE CHAR)
-                           (\GETBASEBIT (fetch (KEYACTION ARMED)
-                                               TABLE)
-                                  CHAR)))
-
-(PUTPROPS TRANSITIONALTGRCODE MACRO ((TABLE CHAR)
-                                     (\GETBASE (fetch (KEYACTION ALTGRAPHCODES) of TABLE)
-                                            CHAR)))
-
-(PUTPROPS TRANSITIONSHIFTCODE MACRO ((TABLE CHAR)
-                                     (\GETBASE (fetch (KEYACTION SHIFTCODES)
-                                                      TABLE)
-                                            CHAR)))
-
-(PUTPROPS TRANSITIONCODE MACRO ((TABLE CHAR)
-                                (\GETBASE (fetch (KEYACTION CODES)
-                                                 TABLE)
-                                       CHAR)))
-
-(PUTPROPS TRANSITIONFLAGS MACRO ((TABLE CHAR)
-                                 (\GETBASEBYTE (fetch (KEYACTION FLAGS)
-                                                      TABLE)
-                                        CHAR)))
-
-[PUTPROPS TRANSITIONDEADLIST MACRO ((TABLE CHAR SHIFTED)
-                                    (\GETBASEPTR (fetch (KEYACTION DEADKEYLIST) of TABLE)
-                                           (LLSH (COND
-                                                    (SHIFTED (IPLUS CHAR \NKEYS \NKEYS))
-                                                    (T CHAR))
-                                                 1]
-
-[PUTPROPS CHECKFORDEADKEY MACRO
-       ((KEYCODE TABLE CHAR SHIFTED)
-        (LET ((CODE KEYCODE))
-             (COND
-                [(IEQP CODE 65535)
-                 `(DEADKEY ,(\GETBASEPTR (fetch (KEYACTION DEADKEYLIST) of TABLE)
-                                   (LLSH (COND
-                                            (SHIFTED (IPLUS CHAR \NKEYS \NKEYS))
-                                            (T CHAR))
-                                         1]
-                (T CODE]
-)
-
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
-
-(BLOCKRECORD KEYACTION (
-                            (* ;; "KEYACTION Table:  For interpreting keystrokes.  Stored as a 8-cell block of untyped pointer hunk storage.")
-
-                            FLAGS                            (* ; "Flag byte per key# (one for down-transtion, 1 for up-.) to describe whether lockshifting occrrs, you ignore the transition, etc.")
-                            CODES                            (* ; 
-                     "Table of character codes generated by each key when no shift key is pressed.")
-                            SHIFTCODES                       (* ; 
-                    "Table of character codes generated by each key when the shift key is pressed.")
-                            ARMED                            (* ; "Not sure...")
-                            INTERRUPTLIST                    (* ; "List of armed interrupts?")
-                            ALTGRAPHCODES                    (* ; 
-                                "Table of codes to be generated when the ALT-GRAPH key is pressed.")
-                            DEADKEYLIST                      (* ; "Block of dead-key handlers, with the nominal up-transition fields filled by the shifted-case tables.  Each %"table%" is an ALIST of orignal code => accented code.  no entry means punt the accent..")
-                            )
-                           FLAGS _ (\ALLOCBLOCK (FOLDHI (IPLUS \NKEYS \NKEYS)
-                                                       BYTESPERCELL))
-                           CODES _ (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS)
-                                                       WORDSPERCELL))
-                           SHIFTCODES _ (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS)
-                                                            WORDSPERCELL))
-                           ARMED _ (\ALLOCBLOCK (FOLDHI (ADD1 \MAXTHINCHAR)
-                                                       BITSPERCELL))
-                           ALTGRAPHCODES _ (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS)
-                                                               WORDSPERCELL))
-                           DEADKEYLIST _ (\ALLOCBLOCK (PLUS \NKEYS \NKEYS \NKEYS \NKEYS)
-                                                T)
-                           (CREATE (\ALLOCBLOCK 7 PTRBLOCK.GCT))
-                           [TYPE? (AND (\BLOCKDATAP DATUM)
-                                           (IGEQ (\#BLOCKDATACELLS DATUM)
-                                                 5)
-                                           (OR (NULL (FETCH (KEYACTION INTERRUPTLIST)
-                                                        OF DATUM))
-                                               (LISTP (FETCH INTERRUPTLIST OF DATUM)))
-                                           (\BLOCKDATAP (FETCH (KEYACTION FLAGS)
-                                                               DATUM))
-                                           (\BLOCKDATAP (FETCH (KEYACTION CODES)
-                                                               DATUM))
-                                           (\BLOCKDATAP (FETCH (KEYACTION ARMED)
-                                                               DATUM])
-)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \NKEYS 112)
-
-
-(CONSTANTS \NKEYS)
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-
-(DECLARE%: EVAL@COMPILE
-
-(BLOCKRECORD RING ((READ WORD)
-                       (WRITE WORD)))
-)
-
-
-
-
-(* ; "can get rid of shiftstate after clients have been fixed")
-
-(DECLARE%: EVAL@COMPILE
-
-(ACCESSFNS SHIFTSTATE [[DUMMYSHIFT (NOT (EQ 0 (LOGAND (\GETBASEBYTE DATUM 0)
-                                                         (LOGOR 1 2]
-                           [DUMMY1SHIFT [NOT (EQ 0 (LOGAND 1 (\GETBASEBYTE DATUM 0]
-                                  (\PUTBASEBYTE DATUM 0 (COND
-                                                           (NEWVALUE (LOGOR 1 (\GETBASEBYTE DATUM 0))
-                                                                  )
-                                                           (T (LOGAND (\GETBASEBYTE DATUM 0)
-                                                                     (LOGXOR \CHARMASK 1]
-                           [DUMMY2SHIFT [NOT (EQ 0 (LOGAND 2 (\GETBASEBYTE DATUM 0]
-                                  (\PUTBASEBYTE DATUM 0 (COND
-                                                           (NEWVALUE (LOGOR 2 (\GETBASEBYTE DATUM 0))
-                                                                  )
-                                                           (T (LOGAND (\GETBASEBYTE DATUM 0)
-                                                                     (LOGXOR \CHARMASK 2]
-                           [DUMMYLOCK [NOT (EQ 0 (LOGAND 4 (\GETBASEBYTE DATUM 0]
-                                  (\PUTBASEBYTE DATUM 0 (COND
-                                                           (NEWVALUE (LOGOR 4 (\GETBASEBYTE DATUM 0))
-                                                                  )
-                                                           (T (LOGAND (\GETBASEBYTE DATUM 0)
-                                                                     (LOGXOR \CHARMASK 4]
-                           [DUMMYSHIFTORLOCK (NOT (EQ 0 (\GETBASEBYTE DATUM 0)))
-                                  (\PUTBASEBYTE DATUM 0 (COND
-                                                           (NEWVALUE (HELP 
-                                                                         " Can't turn on SHIFTORLOCK"
-                                                                           ))
-                                                           (T 0]
-                           [DUMMYCTRL (NOT (EQ 0 (\GETBASEBYTE DATUM 1)))
-                                  (\PUTBASEBYTE DATUM 1 (COND
-                                                           (NEWVALUE 1)
-                                                           (T 0]
-                           [DUMMYMETA (NOT (EQ 0 (\GETBASEBYTE DATUM 2)))
-                                  (\PUTBASEBYTE DATUM 2 (COND
-                                                           (NEWVALUE 1)
-                                                           (T 0]
-                           [DUMMYFONT (NEQ 0 (LOGAND (LLSH 1 3)
-                                                    (\GETBASEBYTE DATUM 3)))
-                                  (\PUTBASEBYTE DATUM 3 (COND
-                                                           (NEWVALUE (LOGOR (LLSH 1 3)
-                                                                            (\GETBASEBYTE DATUM 3)))
-                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
-                                                                     (LOGXOR \CHARMASK
-                                                                            (LLSH 1 3]
-                           [DUMMYUSERMODE1 (NEQ 0 (LOGAND (LLSH 1 0)
-                                                         (\GETBASEBYTE DATUM 3)))
-                                  (\PUTBASEBYTE DATUM 3 (COND
-                                                           (NEWVALUE (LOGOR (LLSH 1 0)
-                                                                            (\GETBASEBYTE DATUM 3)))
-                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
-                                                                     (LOGXOR \CHARMASK
-                                                                            (LLSH 1 0]
-                           [DUMMYUSERMODE2 (NEQ 0 (LOGAND (LLSH 1 1)
-                                                         (\GETBASEBYTE DATUM 3)))
-                                  (\PUTBASEBYTE DATUM 3 (COND
-                                                           (NEWVALUE (LOGOR (LLSH 1 1)
-                                                                            (\GETBASEBYTE DATUM 3)))
-                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
-                                                                     (LOGXOR \CHARMASK
-                                                                            (LLSH 1 1]
-                           [DUMMYUSERMODE3 (NEQ 0 (LOGAND (LLSH 1 2)
-                                                         (\GETBASEBYTE DATUM 3)))
-                                  (\PUTBASEBYTE DATUM 3 (COND
-                                                           (NEWVALUE (LOGOR (LLSH 1 2)
-                                                                            (\GETBASEBYTE DATUM 3)))
-                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
-                                                                     (LOGXOR \CHARMASK
-                                                                            (LLSH 1 2]
-                           [DUMMYALTGRAPH (NEQ 0 (LOGAND (LLSH 1 4)
-                                                        (\GETBASEBYTE DATUM 3)))
-                                  (\PUTBASEBYTE DATUM 3 (COND
-                                                           (NEWVALUE (LOGOR (LLSH 1 4)
-                                                                            (\GETBASEBYTE DATUM 3)))
-                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
-                                                                     (LOGXOR \CHARMASK
-                                                                            (LLSH 1 4]
-                           (DUMMYDEADKEYPENDING (NEQ 0 (LOGAND (LLSH 1 5)
-                                                              (\GETBASEBYTE DATUM 3)))
-                                  (\PUTBASEBYTE DATUM 3 (COND
-                                                           (NEWVALUE (LOGOR (LLSH 1 5)
-                                                                            (\GETBASEBYTE DATUM 3)))
-                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
-                                                                     (LOGXOR \CHARMASK
-                                                                            (LLSH 1 5]
-                          (CREATE (\ALLOCBLOCK (FOLDHI 3 BYTESPERCELL))))
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \SHIFTSTATE \MOUSETIMERTEMP)
-)
-
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ NRINGINDEXWORDS 2)
-
-
-(CONSTANTS NRINGINDEXWORDS)
-)
-
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQ \SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
-
-(RPAQ \SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE)))
-
-
-[CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
-       (\SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE]
-)
-)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \KEYNAMES ((5 %% FIVE)
-                      (4 $ FOUR)
-                      (6 ~ SIX)
-                      (e E)
-                      (7 & SEVEN)
-                      (d D)
-                      (u U)
-                      (v V)
-                      (0 %) ZERO)
-                      (k K)
-                      (- %)
-                      (p P)
-                      (/ ?)
-                      (\ %| FONT LOOKS)
-                      (LF SAME)
-                      (BS <-)
-                      (3 %# THREE)
-                      (2 @ TWO)
-                      (w W)
-                      (q Q)
-                      (s S)
-                      (a A)
-                      (9 %( NINE)
-                      (i I)
-                      (x X)
-                      (o O)
-                      (l L)
-                      (%, <)
-                      (%' %")
-                      (%] })
-                      (BLANK-MIDDLE OPEN DBK-HELP)
-                      (BLANK-TOP KEYBOARD DBK-META)
-                      (1 ! ONE)
-                      (ESC ESCAPE ->)
-                      (TAB =>)
-                      (f F)
-                      (CTRL PROP'S EDIT)
-                      (c C)
-                      (j J)
-                      (b B)
-                      (z Z)
-                      (LSHIFT)
-                      (%. >)
-                      (; %:)
-                      (CR <-%|)
-                      (_ ^)
-                      (DEL DELETE)
-                      (SKIP NEXT)
-                      (r R)
-                      (t T)
-                      (g G)
-                      (y Y)
-                      (h H)
-                      (8 * EIGHT)
-                      (n N)
-                      (m M)
-                      (LOCK)
-                      (SPACE)
-                      (%[ {)
-                      (= +)
-                      (RSHIFT)
-                      (BLANK-BOTTOM STOP)
-                      (MOVE)
-                      (UNDO)
-                      (UTIL0 SUN-KEYPAD=)
-                      (UTIL1 SUN-KEYPAD/)
-                      (UTIL2 SUPER/SUB)
-                      (UTIL3 CASE)
-                      (UTIL4 STRIKEOUT)
-                      (UTIL5 KEYPAD2)
-                      (UTIL6 KEYPAD3 PGDN)
-                      (UTIL7 SUN-LF)
-                      (PAD1 LEFTKEY CAPSLOCK KEYPAD+)
-                      (PAD2 LEFTMIDDLEKEY NUMLOCK KEYPAD-)
-                      (PAD3 MIDDLEKEY SCROLLLOCK KEYPAD*)
-                      (PAD4 RIGHTMIDDLEKEY BREAK KEYPAD/ SUN-PAUSE)
-                      (PAD5 RIGHTKEY DOIT PRTSC)
-                      (LEFT RED MOUSERED)
-                      (RIGHT BLUE MOUSEBLUE)
-                      (MIDDLE YELLOW MOUSEYELLOW)
-                      (MARGINS)
-                      (K41 KEYPAD7 HOME)
-                      (K42 KEYPAD8)
-                      (K43 KEYPAD9 PGUP)
-                      (K44 KEYPAD4)
-                      (K45 KEYPAD5)
-                      (K46 SUN-LEFT-SPACE)
-                      (K47 KEYPAD6)
-                      (K48 SUN-RIGHT-SPACE)
-                      (COPY)
-                      (FIND)
-                      (AGAIN)
-                      (HELP)
-                      (DEF'N EXPAND)
-                      (K4E KEYPAD1 END)
-                      (ALWAYS-ON-1)
-                      (ALWAYS-ON-2)
-                      (CENTER)
-                      (K52 KEYPAD0 INS)
-                      (BOLD)
-                      (ITALICS)
-                      (UNDERLINE)
-                      (SUPERSCRIPT)
-                      (SUBSCRIPT)
-                      (LARGER SMALLER)
-                      (K59 KEYPAD%| KEYPAD.)
-                      (K5A KEYPAD\ KEYPAD, SUN-F10)
-                      (K5B SUN-F11)
-                      (K5C SUN-F12)
-                      (DEFAULTS SUN-PROP)
-                      (K5E SUN-PRTSC)
-                      (K5F SUN-OPEN)))
-)
-
-
-
-(* ;; 
-"\maikokeyactions does not contain keyactions of the form %"2,50%" because it breaks the loadup process on the sun."
-)
-
-
-(RPAQQ \ORIGKEYACTIONS ((0 (53 "%%" NOLOCKSHIFT))
-                            (1 (52 "$" NOLOCKSHIFT))
-                            (2 (54 "~" NOLOCKSHIFT))
-                            (3 ("e" "E" LOCKSHIFT))
-                            (4 (55 "&" NOLOCKSHIFT))
-                            (5 ("d" "D" LOCKSHIFT))
-                            (6 ("u" "U" LOCKSHIFT))
-                            (7 ("v" "V" LOCKSHIFT))
-                            (8 (48 ")" NOLOCKSHIFT))
-                            (9 ("k" "K" LOCKSHIFT))
-                            (10 ("-" "-" NOLOCKSHIFT))
-                            (11 ("p" "P" LOCKSHIFT))
-                            (12 ("/" "?" NOLOCKSHIFT))
-                            (13 ("\" "|" NOLOCKSHIFT))
-                            (14 (10 96 NOLOCKSHIFT))
-                            (15 (8 8 NOLOCKSHIFT))
-                            (16 (51 "#" NOLOCKSHIFT))
-                            (17 (50 "@" NOLOCKSHIFT))
-                            (18 ("w" "W" LOCKSHIFT))
-                            (19 ("q" "Q" LOCKSHIFT))
-                            (20 ("s" "S" LOCKSHIFT))
-                            (21 ("a" "A" LOCKSHIFT))
-                            (22 (57 "(" NOLOCKSHIFT))
-                            (23 ("i" "I" LOCKSHIFT))
-                            (24 ("x" "X" LOCKSHIFT))
-                            (25 ("o" "O" LOCKSHIFT))
-                            (26 ("l" "L" LOCKSHIFT))
-                            (27 ("," "<" NOLOCKSHIFT))
-                            (28 ("'" "%"" NOLOCKSHIFT))
-                            (29 ("]" "}" NOLOCKSHIFT))
-                            (30 (194 194 NOLOCKSHIFT))
-                            (31 (193 193 NOLOCKSHIFT))
-                            (32 (49 "!" NOLOCKSHIFT))
-                            (33 (27 27 NOLOCKSHIFT))
-                            (34 (9 9 NOLOCKSHIFT))
-                            (35 ("f" "F" LOCKSHIFT))
-                            (36 CTRLDOWN . CTRLUP)
-                            (37 ("c" "C" LOCKSHIFT))
-                            (38 ("j" "J" LOCKSHIFT))
-                            (39 ("b" "B" LOCKSHIFT))
-                            (40 ("z" "Z" LOCKSHIFT))
-                            (41 1SHIFTDOWN . 1SHIFTUP)
-                            (42 ("." ">" NOLOCKSHIFT))
-                            (43 (";" ":" NOLOCKSHIFT))
-                            (44 (13 13 NOLOCKSHIFT))
-                            (45 ("_" "^" NOLOCKSHIFT))
-                            (46 (127 535 NOLOCKSHIFT))
-                            (47 ("(" "[" NOLOCKSHIFT))
-                            (48 ("r" "R" LOCKSHIFT))
-                            (49 ("t" "T" LOCKSHIFT))
-                            (50 ("g" "G" LOCKSHIFT))
-                            (51 ("y" "Y" LOCKSHIFT))
-                            (52 ("h" "H" LOCKSHIFT))
-                            (53 (56 "*" NOLOCKSHIFT))
-                            (54 ("n" "N" LOCKSHIFT))
-                            (55 ("m" "M" LOCKSHIFT))
-                            (56 LOCKDOWN . LOCKUP)
-                            (57 (32 32 NOLOCKSHIFT))
-                            (58 ("[" "{" NOLOCKSHIFT))
-                            (59 ("=" "+" NOLOCKSHIFT))
-                            (60 2SHIFTDOWN . 2SHIFTUP)
-                            (61 (195 195 NOLOCKSHIFT))
-                            (63 (")" "]" NOLOCKSHIFT))
-                            (77 EVENT . EVENT)
-                            (78 EVENT . EVENT)
-                            (79 EVENT . EVENT)
-                            (102 LOCKDOWN)
-                            (103 LOCKUP)))
-
-(RPAQQ \DLIONKEYACTIONS ((2 (54 "^" NOLOCKSHIFT))
-                             (10 ("-" "_" NOLOCKSHIFT))
-                             (33 ("\" "|" NOLOCKSHIFT))
-                             (45 (96 "~" NOLOCKSHIFT))
-                             (OPEN METADOWN . METAUP)
-                             (PROP'S CTRLDOWN . CTRLUP)
-                             (SAME METADOWN . METAUP)
-                             (FIND ("2,3" "2,43" NOLOCKSHIFT))
-                             (UNDO ("2,4" "2,44" NOLOCKSHIFT))
-                             (STOP (5 7 NOLOCKSHIFT))
-                             (MOVE)
-                             (COPY)
-                             (AGAIN ("2,10" "2,50" NOLOCKSHIFT))
-                             (CENTER ("2,101" "2,141" NOLOCKSHIFT))
-                             (BOLD ("2,102" "2,142" NOLOCKSHIFT))
-                             (ITALICS ("2,103" "2,143" NOLOCKSHIFT))
-                             (UNDERLINE ("2,106" "2,146" NOLOCKSHIFT))
-                             (SUPERSCRIPT ("2,113" "2,153" NOLOCKSHIFT))
-                             (SUBSCRIPT ("2,114" "2,154" NOLOCKSHIFT))
-                             (LARGER ("2,110" "2,150" NOLOCKSHIFT))
-                             (DEFAULTS ("2,115" "2,155" NOLOCKSHIFT))
-                             (93 (27 "2,64" NOLOCKSHIFT))
-                             (47 ("2,22" "2,62" NOLOCKSHIFT))
-                             (31 ("2,5" "2,45" NOLOCKSHIFT))
-                             (92 ("2,1" "2,41" NOLOCKSHIFT))
-                             (80 ("2,13" "2,53" NOLOCKSHIFT))
-                             (FONT ("2,112" "2,152" NOLOCKSHIFT))))
-
-(RPAQQ \DLIONOSDKEYACTIONS ((56 LOCKTOGGLE)))
-
-(RPAQQ \DORADOKEYACTIONS ((2 (54 "~" NOLOCKSHIFT))
-                              (10 ("-" "-" NOLOCKSHIFT))
-                              (13 ("\" "|" NOLOCKSHIFT))
-                              (14 (10 96 NOLOCKSHIFT))
-                              (33 (27 27 NOLOCKSHIFT))
-                              (45 ("_" "^" NOLOCKSHIFT))))
-
-(RPAQQ \DOVEKEYACTIONS ((2 (54 "^" NOLOCKSHIFT))
-                            (10 ("-" "_" NOLOCKSHIFT))
-                            (33 (27 27 NOLOCKSHIFT))
-                            (56 CTRLDOWN . CTRLUP)
-                            (65 (27 27 NOLOCKSHIFT))
-                            (71 (39 34 NOLOCKSHIFT))
-                            (93 ("2,24" "2,64" NOLOCKSHIFT))
-                            (108 (96 126 NOLOCKSHIFT))
-                            (DBK-META METADOWN . METAUP)
-                            (DBK-HELP ("2,1" "2,41" NOLOCKSHIFT))
-                            (SAME METADOWN . METAUP)
-                            (FIND ("2,3" "2,43" NOLOCKSHIFT))
-                            (UNDO ("2,4" "2,44" NOLOCKSHIFT))
-                            (STOP (5 7 NOLOCKSHIFT))
-                            (EDIT ("2,5" "2,45" NOLOCKSHIFT))
-                            (MOVE)
-                            (COPY)
-                            (AGAIN ("2,10" "2,50" NOLOCKSHIFT))
-                            (CENTER ("2,101" "2,141" NOLOCKSHIFT))
-                            (BOLD ("2,102" "2,142" NOLOCKSHIFT))
-                            (ITALICS ("2,103" "2,143" NOLOCKSHIFT))
-                            (CASE ("2,104" "2,144" NOLOCKSHIFT))
-                            (STRIKEOUT ("2,105" "2,145" NOLOCKSHIFT))
-                            (UNDERLINE ("2,106" "2,146" NOLOCKSHIFT))
-                            (SUPER/SUB ("2,107" "2,147" NOLOCKSHIFT))
-                            (LARGER ("2,110" "2,150" NOLOCKSHIFT))
-                            (MARGINS ("2,111" "2,151" NOLOCKSHIFT))
-                            (LOOKS ("2,112" "2,152" NOLOCKSHIFT))
-                            (CAPSLOCK LOCKTOGGLE)
-                            (NUMLOCK ("2,11" "-" NOLOCKSHIFT))
-                            (SCROLLLOCK ("2,12" 180 NOLOCKSHIFT))
-                            (BREAK (2 184 NOLOCKSHIFT))
-                            (DOIT ("2,13" "2,53" NOLOCKSHIFT))
-                            (KEYPAD7 ("2,14" 55 NOLOCKSHIFT))
-                            (KEYPAD8 (173 56 NOLOCKSHIFT))
-                            (KEYPAD9 ("2,15" 57 NOLOCKSHIFT))
-                            (KEYPAD4 (172 52 NOLOCKSHIFT))
-                            (KEYPAD5 ("2,16" 53 NOLOCKSHIFT))
-                            (KEYPAD6 (174 54 NOLOCKSHIFT))
-                            (KEYPAD1 ("2,17" 49 NOLOCKSHIFT))
-                            (KEYPAD2 (175 50 NOLOCKSHIFT))
-                            (KEYPAD3 ("2,20" 51 NOLOCKSHIFT))
-                            (KEYPAD0 ("2,21" 48 NOLOCKSHIFT))
-                            (KEYPAD%| ("|" 46 NOLOCKSHIFT))
-                            (KEYPAD\ ("\" 44 NOLOCKSHIFT))
-                            (47 ("2,22" "2,62" NOLOCKSHIFT))))
-
-(RPAQQ \DOVEOSDKEYACTIONS ((56 LOCKDOWN . LOCKUP)
-                               (36 CTRLDOWN . CTRLUP)
-                               (CAPSLOCK ("2,5" "2,45" NOLOCKSHIFT))))
-
-(RPAQQ \MAIKOKEYACTIONS ((61 (5 7 NOLOCKSHIFT))
-                             (91 (520 552 NOLOCKSHIFT))
-                             (92 (513 545 NOLOCKSHIFT))
-                             (30 (513 545 NOLOCKSHIFT))
-                             (63 (516 548 NOLOCKSHIFT))
-                             (93 (532 564 NOLOCKSHIFT))
-                             (62)
-                             (111 (329 263 NOLOCKSHIFT))
-                             (89)
-                             (90 (515 547 NOLOCKSHIFT))
-                             (73 (521 521 NOLOCKSHIFT))
-                             (74 (522 522 NOLOCKSHIFT))
-                             (75 (2 2 NOLOCKSHIFT))
-                             (81 (524 55 NOLOCKSHIFT))
-                             (82 (173 56 NOLOCKSHIFT))
-                             (83 (525 57 NOLOCKSHIFT))
-                             (84 (172 52 NOLOCKSHIFT))
-                             (85 (526 53 NOLOCKSHIFT))
-                             (87 (174 54 NOLOCKSHIFT))
-                             (94 (527 49 NOLOCKSHIFT))
-                             (69 (175 50 NOLOCKSHIFT))
-                             (70 (528 51 NOLOCKSHIFT))
-                             (98 (529 48 NOLOCKSHIFT))
-                             (76 (523 555 NOLOCKSHIFT))
-                             (72 LOCKTOGGLE)
-                             (97 (577 609 NOLOCKSHIFT))
-                             (99 (578 610 NOLOCKSHIFT))
-                             (100 (579 611 NOLOCKSHIFT))
-                             (67 (580 612 NOLOCKSHIFT))
-                             (68 (581 613 NOLOCKSHIFT))
-                             (101 (582 614 NOLOCKSHIFT))
-                             (66 (583 615 NOLOCKSHIFT))
-                             (104 (584 616 NOLOCKSHIFT))
-                             (80 (585 617 NOLOCKSHIFT))
-                             (13 (23 21 NOLOCKSHIFT))
-                             (33 (27 27 NOLOCKSHIFT))
-                             (65 (27 27 NOLOCKSHIFT))
-                             (2 (54 94 NOLOCKSHIFT))
-                             (10 (45 95 NOLOCKSHIFT))
-                             (36 CTRLDOWN . CTRLUP)
-                             (56 LOCKTOGGLE . IGNORE)
-                             (45 (96 126 NOLOCKSHIFT))
-                             (31 METADOWN . METAUP)
-                             (14 METADOWN . METAUP)
-                             (71 (10 10 NOLOCKSHIFT))
-                             (47 (530 562 NOLOCKSHIFT))
-                             (105 (92 124 NOLOCKSHIFT))))
-
-(RPAQQ \MAIKOKEYACTIONST4 ((61 ("^E" "^G" NOLOCKSHIFT))
-                               (91 ("2,10" "2,50" NOLOCKSHIFT))
-                               (92 ("2,1" "2,41" NOLOCKSHIFT))
-                               (30 ("2,1" "2,41" NOLOCKSHIFT))
-                               (109 ("2,25" "2,65" NOLOCKSHIFT))
-                               (63 ("2,4" "2,44" NOLOCKSHIFT))
-                               (14 METADOWN . METAUP)
-                               (93 ("2,24" "2,64" NOLOCKSHIFT))
-                               (62)
-                               (111 ("1,111" "1,79" NOLOCKSHIFT))
-                               (89)
-                               (90 ("2,3" "2,43" NOLOCKSHIFT))
-                               (73 ("2,11" "2,11" NOLOCKSHIFT))
-                               (74 ("2,12" "2,12" NOLOCKSHIFT))
-                               (75 ("^B" "^B" NOLOCKSHIFT))
-                               (81 ("2,14" 55 NOLOCKSHIFT))
-                               (82 (173 56 NOLOCKSHIFT))
-                               (83 ("2,15" 57 NOLOCKSHIFT))
-                               (84 (172 52 NOLOCKSHIFT))
-                               (85 ("2,16" 53 NOLOCKSHIFT))
-                               (87 (174 54 NOLOCKSHIFT))
-                               (94 ("2,17" 49 NOLOCKSHIFT))
-                               (69 (175 50 NOLOCKSHIFT))
-                               (70 ("2,20" 51 NOLOCKSHIFT))
-                               (98 ("2,21" 48 NOLOCKSHIFT))
-                               (76 ("2,13" "2,13" NOLOCKSHIFT))
-                               (110 ("2,53" "2,53" NOLOCKSHIFT))
-                               (72 LOCKTOGGLE)
-                               (97 ("2,101" "2,141" NOLOCKSHIFT))
-                               (99 ("2,102" "2,142" NOLOCKSHIFT))
-                               (100 ("2,103" "2,143" NOLOCKSHIFT))
-                               (67 ("2,104" "2,144" NOLOCKSHIFT))
-                               (68 ("2,105" "2,145" NOLOCKSHIFT))
-                               (101 ("2,106" "2,146" NOLOCKSHIFT))
-                               (66 ("2,107" "2,147" NOLOCKSHIFT))
-                               (104 ("2,110" "2,150" NOLOCKSHIFT))
-                               (80 ("2,111" "2,151" NOLOCKSHIFT))
-                               (106 ("2,113" "2,153" NOLOCKSHIFT))
-                               (107 ("2,114" "2,154" NOLOCKSHIFT))
-                               (108 ("2,115" "2,155" NOLOCKSHIFT))
-                               (13 ("^W" "^U" NOLOCKSHIFT))
-                               (33 ("ESC" "ESC" NOLOCKSHIFT))
-                               (64 IGNORE . IGNORE)
-                               (65 (27 27 NOLOCKSHIFT))
-                               (95 IGNORE . IGNORE)
-                               (96 IGNORE . IGNORE)
-                               (102 IGNORE . IGNORE)
-                               (2 ("6" "^" NOLOCKSHIFT))
-                               (10 ("-" "_" NOLOCKSHIFT))
-                               (36 CTRLDOWN . CTRLUP)
-                               (56 LOCKTOGGLE . IGNORE)
-                               (45 ("`" "~" NOLOCKSHIFT))
-                               (31 METADOWN . METAUP)
-                               (71 (10 10 NOLOCKSHIFT))
-                               (47 ("2,22" "2,62" NOLOCKSHIFT))
-                               (86 IGNORE . IGNORE)
-                               (88 IGNORE . IGNORE)
-                               (105 ("\" "|" NOLOCKSHIFT))))
-
-(RPAQQ \MAIKO-JLE-KEYACTIONS ((2 ("6" "&" NOLOCKSHIFT))
-                                  (4 ("7" "'" NOLOCKSHIFT))
-                                  (8 ("0" "0" NOLOCKSHIFT))
-                                  (10 ("\" "_" NOLOCKSHIFT))
-                                  (13 ("^W" "^U" NOLOCKSHIFT))
-                                  (14 METADOWN . METAUP)
-                                  (15 (8 8 NOLOCKSHIFT))
-                                  (17 ("2" "%"" NOLOCKSHIFT))
-                                  (22 ("9" ")" NOLOCKSHIFT))
-                                  (28 (":" "*" NOLOCKSHIFT))
-                                  (29 ("[" "{" NOLOCKSHIFT))
-                                  (30 ("]" "}" NOLOCKSHIFT))
-                                  (31 METADOWN . METAUP)
-                                  (33 ("ESC" "ESC" NOLOCKSHIFT))
-                                  (36 CTRLDOWN . CTRLUP)
-                                  (43 (";" "+" NOLOCKSHIFT))
-                                  (45 ("^" "~" NOLOCKSHIFT))
-                                  (47 ("2,22" "2,62" NOLOCKSHIFT))
-                                  (53 ("8" "(" NOLOCKSHIFT))
-                                  (56 LOCKTOGGLE . IGNORE)
-                                  (58 ("@" "`" NOLOCKSHIFT))
-                                  (59 ("-" "=" NOLOCKSHIFT))
-                                  (61 ("^E" "^G" NOLOCKSHIFT))
-                                  (62)
-                                  (63 ("2,4" "2,44" NOLOCKSHIFT))
-                                  (64 ("2,14" 55 NOLOCKSHIFT))
-                                  (65 (27 27 NOLOCKSHIFT))
-                                  (66 ("2,107" "2,147" NOLOCKSHIFT))
-                                  (67 ("2,104" "2,144" NOLOCKSHIFT))
-                                  (69 ("2,13" "2,53" NOLOCKSHIFT))
-                                  (70 ("2,20" 51 NOLOCKSHIFT))
-                                  (71 (10 10 NOLOCKSHIFT))
-                                  (72 (766 766 NOLOCKSHIFT))
-                                  (73 ("2,11" "2,11" NOLOCKSHIFT))
-                                  (74 ("2,12" "2,12" NOLOCKSHIFT))
-                                  (75 ("^B" "^B" NOLOCKSHIFT))
-                                  (80 ("2,111" "2,151" NOLOCKSHIFT))
-                                  (81 ("2,14" 55 NOLOCKSHIFT))
-                                  (82 (173 56 NOLOCKSHIFT))
-                                  (83 ("2,15" 57 NOLOCKSHIFT))
-                                  (84 (172 52 NOLOCKSHIFT))
-                                  (85 ("2,16" 53 NOLOCKSHIFT))
-                                  (86 (765 765 NOLOCKSHIFT))
-                                  (87 (174 54 NOLOCKSHIFT))
-                                  (88 (770 771 NOLOCKSHIFT))
-                                  (90 ("2,3" "2,43" NOLOCKSHIFT))
-                                  (91 ("2,10" "2,50" NOLOCKSHIFT))
-                                  (92 ("2,1" "2,41" NOLOCKSHIFT))
-                                  (93 ("2,24" "2,64" NOLOCKSHIFT))
-                                  (96 IGNORE . IGNORE)
-                                  (98 ("2,21" 48 NOLOCKSHIFT))
-                                  (99 ("2,102" "2,142" NOLOCKSHIFT))
-                                  (101 ("2,106" "2,146" NOLOCKSHIFT))
-                                  (102 IGNORE . IGNORE)
-                                  (103 (767 768 NOLOCKSHIFT))
-                                  (104 ("2,110" "2,150" NOLOCKSHIFT))
-                                  (105 ("\" "|" NOLOCKSHIFT))
-                                  (106 ("2,113" "2,153" NOLOCKSHIFT))
-                                  (107 ("2,114" "2,154" NOLOCKSHIFT))
-                                  (108 ("2,115" "2,155" NOLOCKSHIFT))
-                                  (109 (769 769 NOLOCKSHIFT))
-                                  (110 ("2,53" "2,53" NOLOCKSHIFT))
-                                  (111 ("1,111" "1,79" NOLOCKSHIFT))))
-
-(RPAQQ \TOSHIBA-KEYACTIONS ((2 ("6" "&" NOLOCKSHIFT))
-                                (4 ("7" "'" NOLOCKSHIFT))
-                                (17 ("2" "%"" NOLOCKSHIFT))
-                                (53 ("8" "(" NOLOCKSHIFT))
-                                (22 ("9" ")" NOLOCKSHIFT))
-                                (8 ("0" "0" NOLOCKSHIFT))
-                                (10 ("-" "=" NOLOCKSHIFT))
-                                (59 ("^" "~" NOLOCKSHIFT))
-                                (45 ("\" "|" NOLOCKSHIFT))
-                                (58 ("@" "`" NOLOCKSHIFT))
-                                (29 ("[" "{" NOLOCKSHIFT))
-                                (105 ("]" "}" NOLOCKSHIFT))
-                                (43 (";" "+" NOLOCKSHIFT))
-                                (28 (":" "*" NOLOCKSHIFT))
-                                (15 (23 95 NOLOCKSHIFT))
-                                (13 (8 8 NOLOCKSHIFT))
-                                (86 METADOWN . METAUP)
-                                (73 (530 562 NOLOCKSHIFT))
-                                (88 ("2,24" "2,64" NOLOCKSHIFT))
-                                (98 IGNORE . IGNORE)
-                                (75 ("2,11" "2,11" NOLOCKSHIFT))
-                                (110 ("2,12" "2,12" NOLOCKSHIFT))
-                                (74 ("^B" "^B" NOLOCKSHIFT))
-                                (64 ("2,14" 55 NOLOCKSHIFT))
-                                (65 (173 56 NOLOCKSHIFT))
-                                (95 ("2,15" 57 NOLOCKSHIFT))
-                                (81 (172 52 NOLOCKSHIFT))
-                                (82 ("2,16" 53 NOLOCKSHIFT))
-                                (83 (174 54 NOLOCKSHIFT))
-                                (84 ("2,17" 49 NOLOCKSHIFT))
-                                (85 (175 50 NOLOCKSHIFT))
-                                (87 ("2,20" 51 NOLOCKSHIFT))
-                                (94 ("2,21" 48 NOLOCKSHIFT))
-                                (69 ("2,13" "2,53" NOLOCKSHIFT))
-                                (70 LOCKTOGGLE)))
-
-(RPAQQ KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS NIL)
-
-(RPAQ? \KEYBOARD.META 256)
-
-(RPAQ? \MODIFIED.KEYACTIONS )
-(DECLARE%: EVAL@COMPILE 
-
-(ADDTOVAR GLOBALVARS \RCLKSECOND \LASTUSERACTION \LASTKEYSTATE)
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \SYSBUFFER \LONGSYSBUF \INTERRUPTSTATE \MODIFIED.KEYACTIONS \MOUSECHORDTICKS 
-       \KEYBOARDEVENTQUEUE \KEYBUFFERING \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION 
-       \TIMER.INTERRUPT.PENDING \ORIGKEYACTIONS \KEYBOARD.META \MOUSECHORDMILLISECONDS 
-       \DORADOKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DOVEKEYACTIONS \DOVEOSDKEYACTIONS)
-)
-
-
-
-(* ; "Key interpretation")
-
-(DEFINEQ
-
-(KEYACTION
  [LAMBDA (KEYNAME ACTIONS TABLE)                        (* ; "Edited 19-Nov-87 16:19 by Snow")
    (LET ((NUMB (OR (SMALLP KEYNAME)
                    (\KEYNAMETONUMBER KEYNAME)))
          (TABLE (OR TABLE \CURRENTKEYACTION)))
         (OR (TYPE? KEYACTION TABLE)
             (\ILLEGAL.ARG TABLE))                           (* ; 
                                                    "Make sure he supplied a valid TABLE argument.")
         (CONS (\KEYACTION1 (\TRANSINDEX NUMB T)
                      (AND ACTIONS (OR (CAR ACTIONS)
                                       'IGNORE))
                      TABLE)
               (\KEYACTION1 (\TRANSINDEX NUMB NIL)
                      (AND ACTIONS (OR (CDR ACTIONS)
                                       'IGNORE))
                      TABLE])
-
-(KEYACTIONTABLE
  [LAMBDA (OLD)                                      (* ; "Edited 23-Mar-92 12:44 by jds")

    (* ;; "Create a fresh key action table (or copy OLD so it can be modified without danger).  Returns a fresh keyaction table.")

    (COND
       (OLD 

              (* ;; "He supplied an existing table; create a copy of it:")

              (OR (type? KEYACTION OLD)
                  (\ILLEGAL.ARG OLD))                        (* ; 
                                                    "Make sure the argument IS a key action table.")
              (create KEYACTION copying OLD))
       (T 
          (* ;; "Create a completely fresh table, filled in from \ORIGKEYACTIONS, and the machine-specific exceptions:")

          (PROG1 (SETQ OLD (create KEYACTION))
              (for X in (APPEND (COPY \ORIGKEYACTIONS)
                                       (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS)
                                       KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS)
                 do (KEYACTION (CAR X)
                               (CDR X)
                               OLD)))])
-
-(KEYBOARDTYPE
  [LAMBDA NIL                                                (* ; "Edited  6-Nov-95 15:35 by ")
                                                             (* ; "Edited 17-Feb-95 14:36 by rmk:")
                                                             (* ; 
                                                           "Edited 16-Jun-92 11:03 by kaplan")

    (* ;; "Returns a symbol identifying the currently connected keyboard type.  For now, infers it from the machine type, defaults to NIL (= unknown).")

    (LET ((MT (MACHINETYPE)))
         (SELECTQ MT
             (MAIKO (OR [CADR (SASSOC (L-CASE (UNIX-GETENV "LDEKBDTYPE"))
                                     '(("type3" SUN3)
                                       ("type4" SUN4)
                                       ("type5" SUN5]
                        (MKATOM (U-CASE (UNIX-GETENV "LDEKBDTYPE")))
                        (AND (STREQUAL "dos" (UNIX-GETPARM "ARCH"))
                             'FULL-IBMPC)))
             ((DORADO DANDELION DOVE) 
                  MT)
             NIL])
-
-(RESETKEYACTION
  [LAMBDA (TABLE FROM RESETINTERRUPTS)                   (* ; "Edited 19-Nov-87 16:55 by Snow")

    (* ;; "Resets the actions of key transitions in the keyaction table TABLE, copying in the actions from FROM.  If RESETINTERRUPTS is true, also copies the interrupt-character settings from FROM.")

    (DECLARE (GLOBALVARS \DEFAULTKEYACTION))
    (* ;; "do some type checking first.")

    (OR (type? KEYACTION TABLE)
        (\ILLEGAL.ARG TABLE))
    (OR FROM (SETQ FROM \DEFAULTKEYACTION))
    (OR (type? KEYACTION FROM)
        (\ILLEGAL.ARG TABLE))
    (* ;; "do the resetting.")

    (\BLT (fetch (KEYACTION FLAGS) of TABLE)
          (fetch (KEYACTION FLAGS) of FROM)
          (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION FLAGS) of TABLE))
                1))
    (\BLT (fetch (KEYACTION CODES) of TABLE)
          (fetch (KEYACTION CODES) of FROM)
          (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION CODES) of TABLE))
                1))
    (\BLT (fetch (KEYACTION SHIFTCODES) of TABLE)
          (fetch (KEYACTION SHIFTCODES) of FROM)
          (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION SHIFTCODES) of TABLE))
                1))
    [if RESETINTERRUPTS
        then (\BLT (fetch (KEYACTION ARMED) of TABLE)
                       (fetch (KEYACTION ARMED) of FROM)
                       (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION ARMED) of TABLE))
                             1))
              (replace (KEYACTION INTERRUPTLIST) of TABLE
                 with (COPY (fetch (KEYACTION INTERRUPTLIST) of FROM]
    TABLE])
-
-(\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS
  [LAMBDA NIL                                            (* ; "Edited 18-Sep-90 22:36 by jds")

    (* ;; 
  "Return a list of machine-specific keyactions appropriate to the machine you're running on.")

    (* ;; "Also take account (on Maiko implementations) of whether we're running under X or not -- the CAPS-LOCK key works differently.")

    (SELECTC \MACHINETYPE
        (\DORADO \DORADOKEYACTIONS)
        (\DANDELION \DLIONKEYACTIONS)
        (\MAIKO (LET [(CAPS-LOCK-ACTIONS (COND
                                            ((EQUAL (UNIX-GETPARM "DISPLAY")
                                                    "X")
                                             '((56 LOCKDOWN . LOCKUP)
                                               (72 LOCKDOWN . LOCKUP]

                     (* ;; "If we're running under X windows, CAPS-LOCK-ACTIONS, appended to the normal keyactions, will reset the keyboard appropriately.")

                     (COND
                        ((EQUAL \SUN.TYPE3KEYBOARD (LOGAND 7 (fetch (IFPAGE DEVCONFIG)
                                                                of \InterfacePage)))
                         (APPEND \MAIKOKEYACTIONS CAPS-LOCK-ACTIONS))
                        ((EQUAL \SUN.TYPE4KEYBOARD (LOGAND 7 (fetch (IFPAGE DEVCONFIG)
                                                                of \InterfacePage)))
                         (APPEND \MAIKOKEYACTIONST4 CAPS-LOCK-ACTIONS))
                        ((EQUAL \SUN.JLEKEYBOARD (LOGAND 7 (fetch (IFPAGE DEVCONFIG) of
                                                                                         
                                                                                       \InterfacePage
                                                                  )))
                         \MAIKO-JLE-KEYACTIONS)
                        ((EQUAL \TOSHIBA.JIS (LOGAND 7 (FETCH (IFPAGE DEVCONFIG) OF 
                                                                                       \InterfacePage
                                                              )))
                                                             (* ; "Toshiba JIS")
                         (APPEND \MAIKOKEYACTIONST4 \TOSHIBA-KEYACTIONS))
                        (T                                   (* ; "default is type3")
                           \MAIKOKEYACTIONS))))
        (\DAYBREAK                                           (* ; 
                  "Moving to a daybreak.  Need to distinguish among the various kinds of keyboard.")

                   (* ;; "For now, we only distinguish between the office keyboards (1 = US, 2 = Euro, 3 = Japanese, 4 = ADM-3), and some yet-to-be-determined Lisp-keyboard number")

                   (COND
                      ((ILEQ (\DoveMisc.ReadKeyboardType)
                             4)                              (* ; 
                                                       "It's an office keyboard.  Set it up right!")
                       (APPEND \DOVEKEYACTIONS \DOVEOSDKEYACTIONS))
                      (T                                     (* ; 
                                          "Lisp keyboard.  Leave the Dove keyactions as they were.")
                         \DOVEKEYACTIONS)))
        NIL])
-
-(\KEYACTION1
  [LAMBDA (TI ACTION TABLE)                              (* ; "Edited  4-Mar-92 13:59 by jds")
    (PROG1 (SELECTC (TRANSITIONFLAGS TABLE TI)
               (IGNORE.TF 'IGNORE)
               ((LIST LOCKSHIFT.TF NOLOCKSHIFT.TF) 
                    [LET (CODE)
                         (LIST (CHECKFORDEADKEY (TRANSITIONCODE TABLE TI)
                                      TABLE TI NIL)
                               (CHECKFORDEADKEY (TRANSITIONSHIFTCODE TABLE TI)
                                      TABLE TI T)
                               (TRANSITIONALTGRCODE TABLE TI)
                               (COND
                                  ((EQ LOCKSHIFT.TF (TRANSITIONFLAGS TABLE TI))
                                   'LOCKSHIFT)
                                  (T 'NOLOCKSHIFT])
               (EVENT.TF 'EVENT)
               (CTRLDOWN.TF 'CTRLDOWN)
               (CTRLUP.TF 'CTRLUP)
               (DEADKEY.TF (LIST 'DEADKEY (TRANSITIONDEADLIST TABLE TI)
                                 (TRANSITIONDEADLIST TABLE TI T)))
               (1SHIFTDOWN.TF '1SHIFTDOWN)
               (1SHIFTUP.TF '1SHIFTUP)
               (2SHIFTDOWN.TF '2SHIFTDOWN)
               (2SHIFTUP.TF '2SHIFTUP)
               (LOCKDOWN.TF 'LOCKDOWN)
               (LOCKUP.TF 'LOCKUP)
               (LOCKTOGGLE.TF 'LOCKTOGGLE)
               (METADOWN.TF 'METADOWN)
               (METAUP.TF 'METAUP)
               (FONTUP.TF 'FONTUP)
               (FONTDOWN.TF 'FONTDOWN)
               (FONTTOGGLE.TF 'FONTTOGGLE)
               (USERMODE1UP.TF 
                    'USERMODE1UP)
               (USERMODE1DOWN.TF 
                    'USERMODE1DOWN)
               (USERMODE1TOGGLE.TF 
                    'USERMODE1TOGGLE)
               (USERMODE2UP.TF 
                    'USERMODE2UP)
               (USERMODE2DOWN.TF 
                    'USERMODE2DOWN)
               (USERMODE2TOGGLE.TF 
                    'USERMODE2TOGGLE)
               (USERMODE3UP.TF 
                    'USERMODE3UP)
               (USERMODE3DOWN.TF 
                    'USERMODE3DOWN)
               (USERMODE3TOGGLE.TF 
                    'USERMODE3TOGGLE)
               (ALTGRUP.TF 'ALTGRUP)
               (ALTGRDOWN.TF 'ALTGRDOWN)
               (ALTGRTOGGLE.TF 
                    'ALTGRTOGGLE)
               (SHOULDNT))
        [SELECTQ ACTION
            ((NIL NOCHANGE))
            (IGNORE (change (TRANSITIONFLAGS TABLE TI)
                           IGNORE.TF))
            (EVENT (change (TRANSITIONFLAGS TABLE TI)
                          EVENT.TF))
            (CTRLUP (change (TRANSITIONFLAGS TABLE TI)
                           CTRLUP.TF))
            (CTRLDOWN (change (TRANSITIONFLAGS TABLE TI)
                             CTRLDOWN.TF))
            (1SHIFTUP (change (TRANSITIONFLAGS TABLE TI)
                             1SHIFTUP.TF))
            (1SHIFTDOWN (change (TRANSITIONFLAGS TABLE TI)
                               1SHIFTDOWN.TF))
            (2SHIFTUP (change (TRANSITIONFLAGS TABLE TI)
                             2SHIFTUP.TF))
            (2SHIFTDOWN (change (TRANSITIONFLAGS TABLE TI)
                               2SHIFTDOWN.TF))
            (LOCKUP (change (TRANSITIONFLAGS TABLE TI)
                           LOCKUP.TF))
            (LOCKDOWN (change (TRANSITIONFLAGS TABLE TI)
                             LOCKDOWN.TF))
            (LOCKTOGGLE (change (TRANSITIONFLAGS TABLE TI)
                               LOCKTOGGLE.TF))
            (METAUP (change (TRANSITIONFLAGS TABLE TI)
                           METAUP.TF))
            (METADOWN (change (TRANSITIONFLAGS TABLE TI)
                             METADOWN.TF))
            (FONTUP (change (TRANSITIONFLAGS TABLE TI)
                           FONTUP.TF))
            (FONTDOWN (change (TRANSITIONFLAGS TABLE TI)
                             FONTDOWN.TF))
            (FONTTOGGLE (change (TRANSITIONFLAGS TABLE TI)
                               FONTTOGGLE.TF))
            (USERMODE1UP (change (TRANSITIONFLAGS TABLE TI)
                                USERMODE1UP.TF))
            (USERMODE1DOWN (change (TRANSITIONFLAGS TABLE TI)
                                  USERMODE1DOWN.TF))
            (USERMODE1TOGGLE 
                 (change (TRANSITIONFLAGS TABLE TI)
                        USERMODE1TOGGLE.TF))
            (USERMODE2UP (change (TRANSITIONFLAGS TABLE TI)
                                USERMODE2UP.TF))
            (USERMODE2DOWN (change (TRANSITIONFLAGS TABLE TI)
                                  USERMODE2DOWN.TF))
            (USERMODE2TOGGLE 
                 (change (TRANSITIONFLAGS TABLE TI)
                        USERMODE2TOGGLE.TF))
            (USERMODE3UP (change (TRANSITIONFLAGS TABLE TI)
                                USERMODE3UP.TF))
            (USERMODE3DOWN (change (TRANSITIONFLAGS TABLE TI)
                                  USERMODE3DOWN.TF))
            (USERMODE3TOGGLE 
                 (change (TRANSITIONFLAGS TABLE TI)
                        USERMODE3TOGGLE.TF))
            (ALTGRUP (change (TRANSITIONFLAGS TABLE TI)
                            ALTGRUP.TF))
            (ALTGRDOWN (change (TRANSITIONFLAGS TABLE TI)
                              ALTGRDOWN.TF))
            (ALTGRTOGGLE (change (TRANSITIONFLAGS TABLE TI)
                                ALTGRTOGGLE.TF))
            (PROG (CODE SHIFTCODE ALTGRCODE ACT DEAD SHIFTDEAD)
                  (COND
                     ([AND [OR (AND (AND (LISTP (CAR (LISTP ACTION)))
                                         (EQ (CAAR (LISTP ACTION))
                                             'DEADKEY))
                                    [SETQ DEAD
                                     (for PAIR in (CADAR (LISTP ACTION))
                                        collect 

                                              (* ;; 
                                  "Make sure we'll take string charcode specs in the deadkey list.")

                                              (CONS (OR (AND (\CHARCODEP (CAR PAIR))
                                                             (CAR PAIR))
                                                        (APPLY* (FUNCTION CHARCODE)
                                                               (CAR PAIR)))
                                                    (OR (AND (\CHARCODEP (CDR PAIR))
                                                             (CDR PAIR))
                                                        (APPLY* (FUNCTION CHARCODE)
                                                               (CDR PAIR]
                                    (SETQ CODE 65535))
                               [\CHARCODEP (SETQ CODE (\GETCHARCODE (CAR (LISTP ACTION]
                               (SETQ CODE (APPLY* (FUNCTION CHARCODE)
                                                 (CAR (LISTP ACTION]
                           [OR (AND (AND (LISTP (CADR (LISTP ACTION)))
                                         (EQ (CAADR (LISTP ACTION))
                                             'DEADKEY))
                                    [SETQ SHIFTDEAD
                                     (for PAIR in (CADADR (LISTP ACTION))
                                        collect (CONS (OR (AND (\CHARCODEP (CAR PAIR))
                                                                   (CAR PAIR))
                                                              (APPLY* (FUNCTION CHARCODE)
                                                                     (CAR PAIR)))
                                                          (OR (AND (\CHARCODEP (CDR PAIR))
                                                                   (CDR PAIR))
                                                              (APPLY* (FUNCTION CHARCODE)
                                                                     (CDR PAIR]
                                    (SETQ SHIFTCODE 65535)
                                    (SETQ ACT (CDR ACTION)))
                               [\CHARCODEP (SETQ SHIFTCODE (\GETCHARCODE (CAR (SETQ ACT
                                                                               (LISTP (CDR ACTION]
                               (SETQ SHIFTCODE (APPLY* (FUNCTION CHARCODE)
                                                      (CAR ACT]
                           (OR (NULL (SETQ ACT (CDR ACT)))
                               (LISTP ACT))
                           (SELECTQ (CAR ACT)
                               ((LOCKSHIFT T) 
                                    (change (TRANSITIONFLAGS TABLE TI)
                                           LOCKSHIFT.TF))
                               ((NOLOCKSHIFT NIL) 
                                    (change (TRANSITIONFLAGS TABLE TI)
                                           NOLOCKSHIFT.TF))
                               (AND [OR [\CHARCODEP (SETQ ALTGRCODE (\GETCHARCODE (CAR ACT]
                                        (SETQ ALTGRCODE (APPLY* (FUNCTION CHARCODE)
                                                               (CAR ACT]
                                    (OR (NULL (SETQ ACT (CDR ACT)))
                                        (LISTP ACT))
                                    (SELECTQ (CAR ACT)
                                        ((LOCKSHIFT T) 
                                             (change (TRANSITIONFLAGS TABLE TI)
                                                    LOCKSHIFT.TF))
                                        ((NOLOCKSHIFT NIL) 
                                             (change (TRANSITIONFLAGS TABLE TI)
                                                    NOLOCKSHIFT.TF))
                                        NIL]
                      (change (TRANSITIONCODE TABLE TI)
                             CODE)
                      (change (TRANSITIONSHIFTCODE TABLE TI)
                             SHIFTCODE)
                      (\RPLPTR (fetch (KEYACTION DEADKEYLIST) of TABLE)
                             (LLSH TI 1)
                             DEAD)
                      (\RPLPTR (fetch (KEYACTION DEADKEYLIST) of TABLE)
                             (LLSH (IPLUS \NKEYS \NKEYS TI)
                                   1)
                             SHIFTDEAD)
                      (AND ALTGRCODE (change (TRANSITIONALTGRCODE TABLE TI)
                                            ALTGRCODE)))
                     (T (\ILLEGAL.ARG ACTION])])
-
-(KEYDOWNP
  [LAMBDA (KEYNAME)                                      (* lmm "18-Apr-85 02:09")
                                                             (* T if the indicated key is 
                                                           instantaneously down.)
    (\NEWKEYDOWNP (\KEYNAMETONUMBER KEYNAME])
-
-(KEYNUMBERP
  [LAMBDA (X)                                                (* ; "Edited 16-Jan-96 13:16 by rmk")
    (AND (SMALLP X)
         (IGEQ X 0)
         (ILESSP X \NKEYS)
         X])
-
-(\KEYNAMETONUMBER
  [LAMBDA (KEYNAME)                                      (* rmk%: " 2-SEP-83 10:29")
    (DECLARE (GLOBALVARS \KEYNAMES))                     (* The fast case is when KEYNAME is 
                                                           lower-case)
    (for X N in \KEYNAMES as I from 0 when (EQMEMB KEYNAME X)
       do (RETURN I)
       finally (RETURN (OR (AND (NEQ KEYNAME (SETQ N (L-CASE KEYNAME)))
                                    (for Y in \KEYNAMES as I from 0
                                       when (EQMEMB N Y) do (RETURN I)))
                               (\ILLEGAL.ARG KEYNAME])
-
-(MODIFY.KEYACTIONS
  [LAMBDA (KeyActions SaveCurrent?)                    (* ; "Edited  2-Feb-89 15:38 by GADENER")
    (PROG1 [if SaveCurrent?
               then (SETQ \MODIFIED.KEYACTIONS (for ITEM in KeyActions
                                                      collect (CONS (CAR ITEM)
                                                                        (KEYACTION (CAR ITEM]
        [for action in KeyActions do (for table in '(\CURRENTKEYACTION 
                                                                               \COMMANDKEYACTION)
                                                    do (KEYACTION (CAR action)
                                                                  (CDR action)
                                                                  (EVAL table])])
-
-(METASHIFT
  [LAMBDA FLG                                            (* ; "Edited 19-Nov-87 16:59 by Snow")

    (* ;; "Sets interpretation of swat key to first arg, where T means meta-shift, NIL means original setting.  Returns previous setting")

    (PROG ((METASTATUS '(METADOWN . METAUP))
           OLDSETTING)
          [SETQ OLDSETTING (KEYACTION 'BLANK-BOTTOM
                                  (AND (IGREATERP FLG 0)
                                       (COND
                                          ((EQ (ARG FLG 1)
                                               T)
                                           METASTATUS)
                                          (T (OR (ARG FLG 1)
                                                 (CDR (ASSOC 'BLANK-BOTTOM \ORIGKEYACTIONS]
          (RETURN (COND
                     ((EQUAL OLDSETTING METASTATUS)
                      T)
                     (T OLDSETTING])
-
-(SHIFTDOWNP
  [LAMBDA (SHIFT)                                        (* lmm "18-Apr-85 01:07")
                                                             (* Tells whether a given shift is 
                                                           down)
    (SELECTQ SHIFT
        (LOCK (fetch (KEYBOARDEVENT LOCK) of \LASTKEYSTATE))
        (META (fetch (KEYBOARDEVENT META) of \LASTKEYSTATE))
        (SHIFT (OR (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE)
                   (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE)))
        (1SHIFT (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE))
        (2SHIFT (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE))
        (SHIFTORLOCK (OR (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE)
                         (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE)
                         (fetch (KEYBOARDEVENT LOCK) of \LASTKEYSTATE)))
        (CTRL (fetch (KEYBOARDEVENT CTRL) of \LASTKEYSTATE))
        (FONT (fetch (KEYBOARDEVENT FONT) of \LASTKEYSTATE))
        (USERMODE1 (fetch (KEYBOARDEVENT USERMODE1) of \LASTKEYSTATE))
        (USERMODE2 (fetch (KEYBOARDEVENT USERMODE2) of \LASTKEYSTATE))
        (USERMODE3 (fetch (KEYBOARDEVENT USERMODE3) of \LASTKEYSTATE))
        (\ILLEGAL.ARG SHIFT])
-)
-
-
-
-(* ; "To support office style 1108 & 1186 keyboards")
-
-(DEFINEQ
-
-(SETUP.OFFICE.KEYBOARD
  [LAMBDA NIL                                            (* jds " 8-Oct-85 16:27")
    (SELECTQ (MACHINETYPE)
        (DANDELION (MODIFY.KEYACTIONS \DLIONOSDKEYACTIONS))
        (DOVE (MODIFY.KEYACTIONS \DOVEOSDKEYACTIONS))
        NIL])
-)
-
-(DEFOPTIMIZER \KEYNAMETONUMBER (&REST X)
-                                   [LET [(CE (CONSTANTEXPRESSIONP (CAR X]
-                                        (COND
-                                           (CE (\KEYNAMETONUMBER (CAR CE)))
-                                           (T 'IGNOREMACRO])
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \TEMPCOPYTIMER MACRO ((X)
-                                (PROGN (\BLT \MOUSETIMERTEMP (LOCF X)
-                                             WORDSPERCELL)
-                                       \MOUSETIMERTEMP)))
-)
-
-
-
-(* ; "Don't copy this optimizer since it expands out to \getbasebit, but do exportit.")
-
-(DECLARE%: DONTCOPY 
-(* "FOLLOWING DEFINITIONS EXPORTED")
-(DEFOPTIMIZER KEYDOWNP (KEYNAME)
-                           `(\NEWKEYDOWNP (\KEYNAMETONUMBER ,KEYNAME)))
-
-(* "END EXPORTED DEFINITIONS")
-
-)
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
-
-[PUTPROPS XKEYDOWNP MACRO ((KEYNAME)
-                           (KEYDOWNP1 (\KEYNAMETONUMBER KEYNAME]
-
-[PUTPROPS KEYDOWNP1 MACRO (OPENLAMBDA (KEYNUMBER)
-                                 (DECLARE (GLOBALVARS \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3
-                                                     \EM.UTILIN \EM.KBDAD4 \EM.KBDAD5))
-                                 (PROG NIL
-                                       (RETURN (EQ 0 (LOGAND (LRSH (LLSH 1 15)
-                                                                   (PROGN 
-                                                             (* (IMOD KEYNUMBER BITSPERWORD) -
-                                                           GETD cause IMOD and BITSPERWORD not 
-                                                           exported to user)
-                                                                          (LOGAND KEYNUMBER 15)))
-                                                            (\GETBASE (SELECTQ (PROGN 
-                                                             (* (FOLDLO KEYNUMBER BITSPERWORD) 
-                                                           GETD follows since FOLDLO and 
-                                                           BITSPERWORD not exported to user)
-                                                                                      (LRSH KEYNUMBER
-                                                                                            4))
-                                                                          (0 \EM.KBDAD0)
-                                                                          (1 \EM.KBDAD1)
-                                                                          (2 \EM.KBDAD2)
-                                                                          (3 \EM.KBDAD3)
-                                                                          (4 \EM.UTILIN)
-                                                                          (5 (OR \EM.KBDAD4 (RETURN)))
-                                                                          (6 (OR \EM.KBDAD5 (RETURN)))
-                                                                          (RETURN))
-                                                                   0]
-
-[PUTPROPS \NEWKEYDOWNP MACRO ((KEYNUMBER)
-                              (EQ 0 (\GETBASEBIT \LASTKEYSTATE KEYNUMBER]
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-
-
-
-(* ; "A raw keyboard device/stream")
-
-(DEFINEQ
-
-(\INIT.KEYBOARD.STREAM
  [LAMBDA NIL                                            (* ; "Edited  4-Sep-87 10:25 by jds")

    (* ;; "Initialize the %"Keyboard%" device:  Set up the FDEV and the prototype keyboard stream in their respective global variables.")

    (DECLARE (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM))
    [\DEFINEDEVICE 'KEYBOARD (SETQ \KEYBOARD.DEVICE (create FDEV
                                                           DEVICENAME _ 'KEYBOARD
                                                           CLOSEFILE _ (FUNCTION NILL)
                                                           EVENTFN _ (FUNCTION \KEYBOARDEVENTFN)
                                                           BIN _ (FUNCTION \GETKEY)
                                                           PEEKBIN _ (FUNCTION \PEEKSYSBUF)
                                                           READP _ (FUNCTION \SYSBUFP)
                                                           EOFP _ (FUNCTION NILL)
                                                           GETFILENAME _
                                                           (FUNCTION (LAMBDA (X MODE)
                                                                       (if (EQ MODE 'INPUT)
                                                                           then \KEYBOARD.STREAM]
    (SETQ \KEYBOARD.STREAM (create STREAM
                                  USERCLOSEABLE _ NIL
                                  USERVISIBLE _ NIL
                                  FULLFILENAME _ '{KEYBOARD}
                                  DEVICE _ \KEYBOARD.DEVICE
                                  ACCESS _ 'INPUT])
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(\INIT.KEYBOARD.STREAM)
-)
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM)
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-
-
-
-(* ; "Hook for a periodic interrupt")
-
-(DEFINEQ
-
-(\DOBUFFEREDTRANSITIONS
  [LAMBDA (\INTERRUPTABLE)
    (DECLARE (SPECVARS \INTERRUPTABLE))              (* ; "Edited  1-Feb-92 11:59 by jds")
    (SETQ \KEYBUFFERING 'INPROGRESS)
    (LET ((PENDINGINTERRUPT))
         (DECLARE (SPECVARS PENDINGINTERRUPT))           (* ; "Used by \DECODETRANSITION")
         [bind R RPTR until (EQ 0 (SETQ R (fetch (RING READ) of \KEYBOARDEVENTQUEUE))
                                        ) do (SETQ RPTR (\ADDBASE \KEYBOARDEVENTQUEUE R)) 
                                                             (* ; "get pointer to this event")
                                                             (* ; 
                             "handle simple keyboard words by calling \DOTRANSITIONS for each word")
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W0) of RPTR)
                                                         (fetch (KEYBOARDEVENT W0) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 0 (fetch (KEYBOARDEVENT
                                                                                      W0)
                                                                             of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W0) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W0) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W0)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W1) of RPTR)
                                                         (fetch (KEYBOARDEVENT W1) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 16 (fetch (KEYBOARDEVENT
                                                                                       W1)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W1) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W1) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W1)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W2) of RPTR)
                                                         (fetch (KEYBOARDEVENT W2) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 32 (fetch (KEYBOARDEVENT
                                                                                       W2)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W2) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W2) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W2)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W3) of RPTR)
                                                         (fetch (KEYBOARDEVENT W3) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 48 (fetch (KEYBOARDEVENT
                                                                                       W3)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W3) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W3) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W3)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W4) of RPTR)
                                                         (fetch (KEYBOARDEVENT W4) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 80 (fetch (KEYBOARDEVENT
                                                                                       W4)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W4) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W4) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W4)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W5) of RPTR)
                                                         (fetch (KEYBOARDEVENT W5) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 96 (fetch (KEYBOARDEVENT
                                                                                       W5)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W5) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W5) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W5)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT WU) of RPTR)
                                                         (fetch (KEYBOARDEVENT WU) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 64 (fetch (KEYBOARDEVENT
                                                                                       WU)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT WU) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT WU) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT WU)
                                                                   of RPTR] 

(* ;;; "now remove event from queue")

                                                (COND
                                                   ((EQ [replace (RING READ) of 
                                                                                  \KEYBOARDEVENTQUEUE
                                                           with (COND
                                                                       ((IGEQ R \KEYBOARDEVENT.LAST)
                                                                        \KEYBOARDEVENT.FIRST)
                                                                       (T (IPLUS \KEYBOARDEVENT.SIZE
                                                                                 R]
                                                        (fetch (RING WRITE) of 
                                                                                  \KEYBOARDEVENTQUEUE
                                                               ))
                                                    (replace (RING READ) of 
                                                                                  \KEYBOARDEVENTQUEUE
                                                       with 0]
         (PROGN                                              (* ; "update dummy shift state")
                (replace DUMMY1SHIFT of \SHIFTSTATE with (fetch (KEYBOARDEVENT 1SHIFT
                                                                                       ) of
                                                                                         
                                                                                        \LASTKEYSTATE
                                                                            ))
                (replace DUMMY2SHIFT of \SHIFTSTATE with (fetch (KEYBOARDEVENT 2SHIFT
                                                                                       ) of
                                                                                         
                                                                                        \LASTKEYSTATE
                                                                            ))
                (replace DUMMYLOCK of \SHIFTSTATE with (fetch (KEYBOARDEVENT LOCK)
                                                                      of \LASTKEYSTATE))
                (replace DUMMYCTRL of \SHIFTSTATE with (fetch (KEYBOARDEVENT CTRL)
                                                                      of \LASTKEYSTATE))
                (replace DUMMYMETA of \SHIFTSTATE with (fetch (KEYBOARDEVENT META)
                                                                      of \LASTKEYSTATE))
                (replace DUMMYFONT of \SHIFTSTATE with (fetch (KEYBOARDEVENT FONT)
                                                                      of \LASTKEYSTATE))
                (replace DUMMYUSERMODE1 of \SHIFTSTATE with (fetch (KEYBOARDEVENT
                                                                                    USERMODE1)
                                                                           of \LASTKEYSTATE))
                (replace DUMMYUSERMODE2 of \SHIFTSTATE with (fetch (KEYBOARDEVENT
                                                                                    USERMODE2)
                                                                           of \LASTKEYSTATE))
                (replace DUMMYUSERMODE3 of \SHIFTSTATE with (fetch (KEYBOARDEVENT
                                                                                    USERMODE3)
                                                                           of \LASTKEYSTATE))
                (replace DUMMYALTGRAPH of \SHIFTSTATE with (fetch (KEYBOARDEVENT
                                                                                   ALTGRAPH)
                                                                          of \LASTKEYSTATE))
                (replace DUMMYDEADKEYPENDING of \SHIFTSTATE with (fetch (
                                                                                        KEYBOARDEVENT
                                                                                         
                                                                                       DEADKEYPENDING
                                                                                         )
                                                                                of \LASTKEYSTATE)
                       ))

         (* ;; "Note: there is a window between the test of READ above and the setting of \KEYBUFFERING below where a keyboard transition can be ignored until the next transition causes \KEYBUFFERING to be set again")

         (COND
            ((NOT (OR PENDINGINTERRUPT \PENDINGINTERRUPT))   (* ; 
                                     "No interrupt noticed this time or on any previous invocation")
             (SETQ \KEYBUFFERING NIL))
            ((NOT (\GETBASEPTR (\STKSCAN '\INTERRUPTABLE)
                         0))                                 (* ; 
                                                      "We're not interruptable, so try again later")
             (SETQ \PENDINGINTERRUPT T)
             (SETQ \KEYBUFFERING NIL))
            (T (SETQ \PENDINGINTERRUPT NIL)
               (SETQ \KEYBUFFERING NIL)
               (LET ((\INTERRUPTABLE T))
                    (INTERRUPTED])
-
-(\TIMER.INTERRUPTFRAME
  [LAMBDA NIL                                            (* lmm "22-Apr-85 09:47")
                                                             (* place holder for periodic 
                                                           interrupts)
    (if NIL
        then (APPLY* \PERIODIC.INTERRUPT)
              (if \PERIODIC.INTERRUPT
                  then (SETUPTIMER (QUOTIENT (TIMES \PERIODIC.INTERRUPT.FREQUENCY \RCLKSECOND)
                                              77)
                                  (LOCF (fetch DLMOUSETIMER of \MISCSTATS))
                                  'TICKS)
                        (SETQ \TIMER.INTERRUPT.PENDING T])
-
-(\PERIODIC.INTERRUPTFRAME
  [LAMBDA NIL
    (DECLARE (GLOBALVARS \PERIODIC.INTERRUPT))       (* lmm "16-Jul-85 16:22")
    (LET ((FN \PERIODIC.INTERRUPT))
         (AND FN (SPREADAPPLY* FN])
-)
-
-(RPAQ? \KEYBUFFERING )
-
-(RPAQ? \PERIODIC.INTERRUPT )
-
-(RPAQ? \TIMER.INTERRUPT.PENDING )
-
-(RPAQ? \PERIODIC.INTERRUPT.FREQUENCY 77)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(LOCALVARS . T)
-)
-
-
-
-(* ; "cursor and mouse related functions.")
-
-(DEFINEQ
-
-(\HARDCURSORUP
  [LAMBDA (NEWCURSOR INVERTFLG)                       (* ; "Edited  2-Jan-2000 18:10 by kaplan")
                                                             (* ; 
   "version of \CURSORUP that knows about the possibility of the cursor being on the color screen.")
    (PROG (IMAGE)
          (SETQ \SOFTCURSORP NIL)
          (SETQ \CURRENTCURSOR NEWCURSOR)
          (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR))
          [COND
             ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)
                       (fetch (BITMAP BITMAPBITSPERPIXEL) of \CURSORDESTINATION)))
              (\CURSORBITSPERPIXEL NEWCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL) of 
                                                                                   \CURSORDESTINATION
                                                        ))
              (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR]
          (BITBLT IMAGE 0 0 CursorBitMap 0 (IDIFFERENCE HARDCURSORHEIGHT (fetch (BITMAP 
                                                                                         BITMAPHEIGHT
                                                                                           )
                                                                            of IMAGE))
                 HARDCURSORWIDTH HARDCURSORHEIGHT (COND
                                                     (INVERTFLG 'INVERT)
                                                     (T 'INPUT))
                 'REPLACE)
          (SELECTC \MACHINETYPE
              (\DAYBREAK (\DoveDisplay.SetCursorShape CursorBitMap))
              (\MAIKO (SUBRCALL DSPCURSOR (fetch (CURSOR CUHOTSPOTX) of NEWCURSOR)
                             (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR)))
              NIL])
-
-(\HARDCURSORPOSITION
  [LAMBDA (XPOS YPOS)                                    (* kbr%: "13-Jun-85 21:24")
          (* sets cursor position, adjusts for hotspot and tty region limits.
        XPOS and YPOS are the screen coordinates of the hotspot location.)

    (DECLARE (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURSORDESTWIDTH \CURSORDESTHEIGHT))
          (* YPOS is reflected around CURSORYMAX because the screen has
        (0,0) as the upper left corner. *)

    (SETQ YPOS (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT)
                      YPOS))                                 (* Clip coordinates *)
    (SETQ XPOS (UNSIGNED (IDIFFERENCE (COND
                                         ((ILESSP XPOS 0)
                                          0)
                                         ((IGEQ XPOS \CURSORDESTWIDTH)
                                          (SUB1 \CURSORDESTWIDTH))
                                         (T XPOS))
                                \CURSORHOTSPOTX)
                      BITSPERWORD))
    (SETQ YPOS (UNSIGNED (IDIFFERENCE (COND
                                         ((ILESSP YPOS 0)
                                          0)
                                         ((IGEQ YPOS \CURSORDESTHEIGHT)
                                          (SUB1 \CURSORDESTHEIGHT))
                                         (T YPOS))
                                \CURSORHOTSPOTY)
                      BITSPERWORD))
    [COND
       ((EQ \MACHINETYPE \DANDELION)                         (* Temporary workaround)
        (COND
           ((IGREATERP YPOS 32767)
            (SETQ YPOS 0)))
        (COND
           ((IGREATERP XPOS 32767)
            (SETQ XPOS 0]
    (\SETMOUSEXY XPOS YPOS)
    (PROGN 
          (* change the cursor position too so that GETMOUSESTATE will get the correct 
        values if it is called before the next 60 cycle interrupt.)

           (\PUTBASE \EM.CURSORX 0 XPOS)
           (\PUTBASE \EM.CURSORY 0 YPOS))
    NIL])
-
-(\HARDCURSORDOWN
  [LAMBDA NIL                                            (* kbr%: "23-Apr-85 18:26")
    (\CLEARBM (CURSORBITMAP])
-)
-(DEFINEQ
-
-(CURSOR.INIT
  [LAMBDA NIL                                            (* kbr%: "23-Jan-86 17:34")
    (PROG (DESTBPL)                                          (* Assorted globals for doing the 
                                                           color cursor. *)
          (SETQ \CURSORDESTINATION ScreenBitMap)
          (SETQ \SOFTCURSORUPBM NIL)
          (SETQ \SOFTCURSORDOWNBM NIL)
          (SETQ \CURSORDESTLINE 0)
          (SETQ \CURSORDESTLINEBASE (fetch (BITMAP BITMAPBASE) of ScreenBitMap))
          (SETQ \CURSORDESTWIDTH (fetch (BITMAP BITMAPWIDTH) of ScreenBitMap))
          (SETQ \CURSORDESTHEIGHT (fetch (BITMAP BITMAPHEIGHT) of ScreenBitMap))
          (SETQ \CURSORDESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of ScreenBitMap))
                                                             (* Initialize PILOTBBTs.
                                                           *)
          (SETQ DESTBPL (UNFOLD \CURSORDESTRASTERWIDTH BITSPERWORD))
          (* These PILOTBBTs are the mixing areas for forming the color cursor image.
        *)
                                                             (* Does SCREEN to DOWNBM via INPUT, 
                                                           REPLACE. *)
          (SETQ \SOFTCURSORBBT1
           (create PILOTBBT
                  PBTSOURCEBPL _ DESTBPL
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 0))
          (\LOCKCELL \SOFTCURSORBBT1)                        (* Does DOWNBM to UPBM via INPUT, 
                                                           REPLACE. *)
          (SETQ \SOFTCURSORBBT2
           (create PILOTBBT
                  PBTDESTBIT _ 0
                  PBTSOURCEBIT _ 0
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 0))
          (\LOCKCELL \SOFTCURSORBBT2)                        (* Does MASK to UPBM via INPUT, 
                                                           ERASE. *)
          (SETQ \SOFTCURSORBBT3
           (create PILOTBBT
                  PBTDESTBIT _ 0
                  PBTSOURCEBIT _ 0
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 1
                  PBTOPERATION _ 1))
          (\LOCKCELL \SOFTCURSORBBT3)                        (* Does IMAGE to UPBM via INPUT, 
                                                           PAINT. *)
          (SETQ \SOFTCURSORBBT4
           (create PILOTBBT
                  PBTDESTBIT _ 0
                  PBTSOURCEBIT _ 0
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 2))
          (\LOCKCELL \SOFTCURSORBBT4)                        (* Does UPBM to SCREEN via INPUT, 
                                                           REPLACE. *)
          (SETQ \SOFTCURSORBBT5
           (create PILOTBBT
                  PBTDESTBPL _ DESTBPL
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 0))
          (\LOCKCELL \SOFTCURSORBBT5)                        (* Does DOWNBM to SCREEN via INPUT, 
                                                           REPLACE. *)
          (SETQ \SOFTCURSORBBT6
           (create PILOTBBT
                  PBTDESTBPL _ DESTBPL
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 0))
          (\LOCKCELL \SOFTCURSORBBT6)                        (* Lock things down.
                                                           *)
      ])
-
-(\CURSORDESTINATION
  [LAMBDA (DESTINATION)                                  (* kbr%: " 2-Sep-85 20:13")
                                                             (* Change DESTINATION of 
                                                           \CURRENTCURSOR, assuming it is down.
                                                           *)
    (PROG (DESTBPL)
          (COND
             ((NOT (EQ DESTINATION \CURSORDESTINATION))
              (UNINTERRUPTABLY
                  [COND
                     ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CURSOR
                                                                                         CUIMAGE)
                                                                                of \CURRENTCURSOR
                                                                                    ))
                               (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION)))
                      (\CURSORBITSPERPIXEL \CURRENTCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL)
                                                                 of DESTINATION]
                  (\SETMOUSEXY 0 0)
                  (\PUTBASE \EM.CURSORX 0 0)
                  (\PUTBASE \EM.CURSORY 0 0)
                  (SETQ \CURSORDESTLINE 0)
                  (SETQ.NOREF \CURSORDESTLINEBASE (fetch (BITMAP BITMAPBASE) of DESTINATION))
                  (SETQ \CURSORDESTWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION))
                  (SETQ \CURSORDESTHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTINATION))
                  (SETQ \CURSORDESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of 
                                                                                          DESTINATION
                                                      ))
                  (SETQ DESTBPL (UNFOLD \CURSORDESTRASTERWIDTH BITSPERWORD))
                  (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT1 with DESTBPL)
                  (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT5 with DESTBPL)
                  (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT6 with DESTBPL)
                  (SETQ \CURSORDESTINATION DESTINATION))])
-
-(\SOFTCURSORUP
  [LAMBDA (NEWCURSOR)                                    (* kbr%: " 2-Sep-85 20:15")
          (* Put soft NEWCURSOR up, assuming soft cursor is down.
        *)

    (PROG (IMAGE MASK WIDTH BWIDTH HEIGHT CURSORBITSPERPIXEL CURSORBPL UPBMBASE DOWNBMBASE)
                                                             (* Get cursor IMAGE & MASK.
                                                           *)
          (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR))
          (SETQ MASK (fetch (CURSOR CUMASK) of NEWCURSOR))
          (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of IMAGE))
          (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of IMAGE))
          (SETQ CURSORBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE))
                                                             (* Create new UPBM & DOWNBM caches 
                                                           if necessary. *)
          (COND
             ((NOT (AND (type? BITMAP \SOFTCURSORUPBM)
                        (EQ (fetch (BITMAP BITMAPWIDTH) of \SOFTCURSORUPBM)
                            WIDTH)
                        (EQ (fetch (BITMAP BITMAPHEIGHT) of \SOFTCURSORUPBM)
                            HEIGHT)
                        (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of \SOFTCURSORUPBM)
                            CURSORBITSPERPIXEL)))
              (SETQ \SOFTCURSORWIDTH WIDTH)
              (SETQ \SOFTCURSORHEIGHT HEIGHT)
              (SETQ \SOFTCURSORUPBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL))
              (SETQ \SOFTCURSORDOWNBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL))
              (SETQ UPBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM))
              (\TEMPLOCKPAGES UPBMBASE 1)
              (SETQ DOWNBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM))
              (\TEMPLOCKPAGES DOWNBMBASE 1)
              (SETQ CURSORBPL (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH) of IMAGE)
                                     BITSPERWORD))
              (SETQ BWIDTH (ITIMES (fetch (BITMAP BITMAPWIDTH) of IMAGE)
                                  (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)))
              (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT1 with CURSORBPL)
              (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT2 with UPBMBASE)
              (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT2 with CURSORBPL)
              (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT2 with DOWNBMBASE)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT2 with CURSORBPL)
              (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT2 with BWIDTH)
              (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT2 with HEIGHT)
              (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT3 with UPBMBASE)
              (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT3 with CURSORBPL)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT3 with CURSORBPL)
              (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT3 with BWIDTH)
              (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT3 with HEIGHT)
              (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT4 with UPBMBASE)
              (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT4 with CURSORBPL)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT4 with CURSORBPL)
              (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT4 with BWIDTH)
              (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT4 with HEIGHT)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT5 with CURSORBPL)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT6 with CURSORBPL)))
                                                             (* Change PILOTBBTs.
                                                           *)
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT3 with (fetch (BITMAP 
                                                                                           BITMAPBASE
                                                                                              )
                                                                               of MASK))
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT4 with (fetch (BITMAP 
                                                                                           BITMAPBASE
                                                                                              )
                                                                               of IMAGE))
                                                             (* Put up new \CURRENTCURSOR.
                                                           *)
          (SETQ \CURRENTCURSOR NEWCURSOR)
          (\TEMPLOCKPAGES \CURRENTCURSOR 1)
          (SETQ \SOFTCURSORP T)
          (\SOFTCURSORUPCURRENT])
-
-(\SOFTCURSORUPCURRENT
  [LAMBDA NIL                                            (* kbr%: "18-Aug-85 15:09")
          (* Put soft \CURRENTCURSOR up, assuming soft cursor is down.
        *)

    (PROG (DISPINTERRUPT X Y XBASE YBASE WIDTH HEIGHT BITSPERPIXEL MINUSDESTRASTERWIDTH DEST DESTBIT 
                 SOURCEOFFSET UPBMSOURCE DOWNBMSOURCE SOURCEBIT)
          (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))
          (\PUTBASE \EM.DISPINTERRUPT 0 0)
          (SETQ \SOFTCURSORUPP T)                            (* Roughly, we want to
                                                           (BITBLT CURSOR XBASE YBASE SCREEN X 
                                                           Y WIDTH HEIGHT) *)
          (SETQ X (SIGNED (\GETBASE \EM.MOUSEX 0)
                         BITSPERWORD))
          (SETQ Y (SIGNED (\GETBASE \EM.MOUSEY 0)
                         BITSPERWORD))
          (SETQ XBASE 0)
          (SETQ YBASE 0)
          (SETQ WIDTH \SOFTCURSORWIDTH)
          (SETQ HEIGHT \SOFTCURSORHEIGHT)                    (* Clip off screen parts of cursor.
                                                           *)
          [COND
             ((IGREATERP 0 X)                                (* Some of cursor is to left of 
                                                           screen. *)
              (SETQ XBASE (IMINUS X))
              (SETQ WIDTH (IDIFFERENCE WIDTH XBASE))
              (SETQ X 0))
             ((IGREATERP (IPLUS X WIDTH)
                     \CURSORDESTWIDTH)                       (* Some of cursor is to right of 
                                                           screen. *)
              (SETQ WIDTH (IDIFFERENCE \CURSORDESTWIDTH X]
          (COND
             ((ILESSP WIDTH 0)
              (GO EXIT)))
          [COND
             ((IGREATERP 0 Y)                                (* Some of cursor is to above of 
                                                           screen. *)
              (SETQ YBASE (IMINUS Y))
              (SETQ HEIGHT (IDIFFERENCE HEIGHT YBASE))
              (SETQ Y 0))
             ((IGREATERP (IPLUS Y HEIGHT)
                     \CURSORDESTHEIGHT)                      (* Some of cursor is to below of 
                                                           screen. *)
              (SETQ HEIGHT (IDIFFERENCE \CURSORDESTHEIGHT Y]
          (COND
             ((ILESSP HEIGHT 0)
              (GO EXIT)))
          (* These loops reset \CURSORDESTLINEBASE while avoiding large number 
        arithmetic. *)

          [COND
             [(IGREATERP \CURSORDESTLINE Y)
              (SETQ MINUSDESTRASTERWIDTH (IMINUS \CURSORDESTRASTERWIDTH))
              (until (EQ \CURSORDESTLINE Y) do (SETQ \CURSORDESTLINE (SUB1 \CURSORDESTLINE))
                                                      (SETQ.NOREF \CURSORDESTLINEBASE
                                                             (\ADDBASE \CURSORDESTLINEBASE 
                                                                    MINUSDESTRASTERWIDTH]
             ((ILESSP \CURSORDESTLINE Y)
              (until (EQ \CURSORDESTLINE Y) do (SETQ \CURSORDESTLINE (ADD1 \CURSORDESTLINE))
                                                      (SETQ.NOREF \CURSORDESTLINEBASE
                                                             (\ADDBASE \CURSORDESTLINEBASE 
                                                                    \CURSORDESTRASTERWIDTH]
                                                             (* Reset PILOTBBTs.
                                                           *)
          (SETQ BITSPERPIXEL (fetch (CURSOR CUBITSPERPIXEL) of \CURRENTCURSOR))
          (SETQ X (ITIMES BITSPERPIXEL X))
          (SETQ XBASE (ITIMES BITSPERPIXEL XBASE))
          (SETQ WIDTH (ITIMES BITSPERPIXEL WIDTH))
          (SETQ DEST \CURSORDESTLINEBASE)
          (SETQ DESTBIT X)
          (SETQ SOURCEOFFSET (ITIMES YBASE (fetch (BITMAP BITMAPRASTERWIDTH) of 
                                                                                      \SOFTCURSORUPBM
                                                  )))
          (SETQ UPBMSOURCE (\ADDBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM)
                                  SOURCEOFFSET))
          (SETQ DOWNBMSOURCE (\ADDBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM)
                                    SOURCEOFFSET))
          (SETQ SOURCEBIT XBASE)
          (* TBW%: Most of these fields only need to be set if we are clipping this 
        time or the previous time we put the cursor up.
        *)

          (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT1 with DOWNBMSOURCE)
          (replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT1 with SOURCEBIT)
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT1 with DEST)
          (replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT1 with DESTBIT)
          (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT1 with WIDTH)
          (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT1 with HEIGHT)
          (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT5 with DEST)
          (replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT5 with DESTBIT)
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT5 with UPBMSOURCE)
          (replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT5 with SOURCEBIT)
          (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT5 with WIDTH)
          (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT5 with HEIGHT)
          (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT6 with DEST)
          (replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT6 with DESTBIT)
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT6 with DOWNBMSOURCE)
          (replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT6 with SOURCEBIT)
          (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT6 with WIDTH)
          (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT6 with HEIGHT)
                                                             (* Save background behind cursor.
                                                           *)
          (\PILOTBITBLT \SOFTCURSORBBT1 0)                   (* Compute cursor appearance.
                                                           UPBM = (OR IMAGE (AND DOWNBM
                                                           (NOT MASK))) *)
          (\PILOTBITBLT \SOFTCURSORBBT2 0)
          (\PILOTBITBLT \SOFTCURSORBBT3 0)
          (\PILOTBITBLT \SOFTCURSORBBT4 0)                   (* Put color cursor up.
                                                           *)
          (\SOFTCURSORPILOTBITBLT \SOFTCURSORBBT5 0)
      EXIT
          (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT])
-
-(\SOFTCURSORPOSITION
  [LAMBDA (X Y)                                          (* kbr%: "18-Aug-85 14:50")
                                                             (* Move soft cursor.
                                                           *)
    (PROG (DISPINTERRUPT)
          (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))
          (\PUTBASE \EM.DISPINTERRUPT 0 0)
          [COND
             ((OR (NOT (EQ (\GETBASE \EM.CURSORX 0)
                           X))
                  (NOT (EQ (\GETBASE \EM.CURSORY 0)
                           Y)))
              (COND
                 (\SOFTCURSORUPP (\SOFTCURSORDOWN)
                        (\SOFTCURSORUPCURRENT]
          (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT])
-
-(\SOFTCURSORDOWN
  [LAMBDA NIL                                            (* kbr%: " 6-Jul-85 00:09")
                                                             (* Take COLOR cursor down.
                                                           *)
    (PROG (DISPINTERRUPT)                                    (* \SOFTCURSORUPP must be set to NIL 
                                                           before BITBLTing. *)
          (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))
          (\PUTBASE \EM.DISPINTERRUPT 0 0)
          (SETQ \SOFTCURSORUPP NIL)
          (\SOFTCURSORPILOTBITBLT \SOFTCURSORBBT6 0)
          (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT])
-
-(CURSORPROP
  [LAMBDA X                                              (* kbr%: "11-Jan-86 20:03")
    (COND
       ((IGREATERP X 2)
        (PUTCURSORPROP (ARG X 1)
               (ARG X 2)
               (ARG X 3)))
       ((EQ X 2)
        (GETCURSORPROP (ARG X 1)
               (ARG X 2)))
       (T (\ILLEGAL.ARG NIL])
-
-(GETCURSORPROP
  [LAMBDA (CURSOR PROP)                              (* kbr%: "26-Apr-85 11:18")
    (LISTGET (fetch (CURSOR CUDATA) of CURSOR)
           PROP])
-
-(PUTCURSORPROP
  [LAMBDA (CURSOR PROP VALUE)                        (* kbr%: "26-Apr-85 11:18")
    (PROG (OLDDATA OLDVALUE)
          (SETQ OLDDATA (fetch (CURSOR CUDATA) of CURSOR))
          [COND
             [OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP))
                    (COND
                       (VALUE (LISTPUT OLDDATA PROP VALUE))
                       (OLDVALUE (COND
                                    [(EQ (CAR OLDDATA)
                                         PROP)
                                     (replace (CURSOR CUDATA) of CURSOR
                                        with (CDDR (fetch (CURSOR CUDATA) of CURSOR]
                                    (T (FOR TAIL ON (CDR OLDDATA) BY (CDDR TAIL)
                                          WHEN (EQ (CADR TAIL)
                                                       PROP) DO (FRPLACD TAIL (CDDDR TAIL))
                                                                   (RETURN]
             (VALUE (replace (CURSOR CUDATA) of CURSOR with (LIST PROP VALUE]
          (RETURN OLDVALUE])
-
-(\CURSORBITSPERPIXEL
  [LAMBDA (CURSOR NEWBITSPERPIXEL)                   (* kbr%: "12-May-85 17:15")
          (* Swap in NEWBITSPERPIXEL IMAGE and MASK, creating them if necessary.
        *)

    (PROG (OLDBITSPERPIXEL OLDIMAGE OLDMASK WHITE BLACK NEWIMAGE NEWMASK)
          (SETQ OLDBITSPERPIXEL (fetch (CURSOR CUBITSPERPIXEL) of CURSOR))
          (COND
             ((EQ OLDBITSPERPIXEL NEWBITSPERPIXEL)
              (RETURN)))                                     (* Save OLDIMAGE and OLDMASK.
                                                           *)
          (SETQ OLDIMAGE (fetch (CURSOR CUIMAGE) of CURSOR))
          (SETQ OLDMASK (fetch (CURSOR CUMASK) of CURSOR))
          (CURSORPROP CURSOR (\CURSORIMAGEPROPNAME OLDBITSPERPIXEL)
                 OLDIMAGE)
          (CURSORPROP CURSOR (\CURSORMASKPROPNAME OLDBITSPERPIXEL)
                 OLDMASK)
          (* Unsave NEWIMAGE and NEWMASK if possible, otherwise create them.
        *)

          [COND
             [(SETQ NEWIMAGE (CURSORPROP CURSOR (\CURSORIMAGEPROPNAME NEWBITSPERPIXEL)))
                                                             (* Use cached NEWIMAGE & NEWMASK.
                                                           *)
              (SETQ NEWMASK (CURSORPROP CURSOR (\CURSORMASKPROPNAME NEWBITSPERPIXEL]
             (T                                              (* Create NEWIMAGE & NEWMASK.
                                                           *)
                (SETQ WHITE (MASK.1'S 0 NEWBITSPERPIXEL))
                (SETQ BLACK 0)
                (SETQ NEWIMAGE (COLORIZEBITMAP (CURSORPROP CURSOR 'IMAGE1)
                                      BLACK WHITE NEWBITSPERPIXEL))
                (SETQ NEWMASK (COLORIZEBITMAP (CURSORPROP CURSOR 'MASK1)
                                     BLACK WHITE NEWBITSPERPIXEL]
          (replace (CURSOR CUIMAGE) of CURSOR with NEWIMAGE)
          (replace (CURSOR CUMASK) of CURSOR with NEWMASK])
-
-(\CURSORIMAGEPROPNAME
  [LAMBDA (BITSPERPIXEL)                                 (* kbr%: "26-Apr-85 11:18")
    (SELECTQ BITSPERPIXEL
        (1 'IMAGE1)
        (4 'IMAGE4)
        (8 'IMAGE8)
        (SHOULDNT])
-
-(\CURSORMASKPROPNAME
  [LAMBDA (BITSPERPIXEL)                                 (* kbr%: "26-Apr-85 11:18")
    (SELECTQ BITSPERPIXEL
        (1 'MASK1)
        (4 'MASK4)
        (8 'MASK8)
        (SHOULDNT])
-)
-(DEFINEQ
-
-(CURSORCREATE
  [LAMBDA (IMAGE MASK HOTSPOTX HOTSPOTY DATA)            (* ; "Edited 10-Jul-92 16:32 by cat")
                                                             (* ; "Edited 31-Jul-87 10:01 by jds")

    (* ;; "creates a cursor from a bitmap.  HOTSPOTX and HOTSPOTY specify the hotspot.")

    (* ;; "INVARIANTS:  the hot spot X and Y must be in the range 0..(width - 1) and 0..(height - 1), respectively.")

    (PROG (CURSOR)
          (COND
             ((OR (FIXP MASK)
                  (POSITIONP MASK))

              (* ;; "If Mask is a fixp then we presume this is the old arg list (bitmap x y).  the cursor filepkgtype has been changed to write the new arg list.  The other is provided for (dubious) compatibility")

              (SETQ HOTSPOTY HOTSPOTX)
              (SETQ HOTSPOTX MASK)
              (SETQ MASK NIL)))

     (* ;; "Make sure that the image and mask bitmaps are no larger than the hardware cursor, i.e. 16x16 bits [AR 8916 7/31/87]:")

          (COND
             ((OR (IGREATERP (BITMAPWIDTH IMAGE)
                         16)
                  (IGREATERP (BITMAPHEIGHT IMAGE)
                         16))                                (* ; "IMAGE is too big.")
              (\ILLEGAL.ARG IMAGE))
             ((NOT MASK)                                     (* ; "No mask, so it's OK")
              )
             ((OR (IGREATERP (BITMAPWIDTH MASK)
                         16)
                  (IGREATERP (BITMAPHEIGHT MASK)
                         16))                                (* ; "MASK is too big.")
              (\ILLEGAL.ARG MASK)))
          [COND
             ((POSITIONP HOTSPOTX)

              (* ;; 
            "The hot spot can be specified as a position in one arg, rather than X and Y in two:")

              (SETQ HOTSPOTY (fetch (POSITION YCOORD) of HOTSPOTX))
              (SETQ HOTSPOTX (fetch (POSITION XCOORD) of HOTSPOTX]
          (SETQ CURSOR (create CURSOR
                              CUIMAGE _ IMAGE
                              CUMASK _ (OR MASK IMAGE)
                              CUHOTSPOTX _ (IMAX 0 (IMIN (SUB1 (BITMAPWIDTH IMAGE))
                                                         (OR (FIXP HOTSPOTX)
                                                             0)))
                              CUHOTSPOTY _ [IMAX 0 (IMIN (SUB1 (BITMAPHEIGHT IMAGE))
                                                         (OR (FIXP HOTSPOTY)
                                                             (SUB1 (BITMAPHEIGHT IMAGE]
                              CUDATA _ DATA))
          (RETURN CURSOR])
-
-(CURSOR
  [LAMBDA (NEWCURSOR INVERTFLG)                          (* ; "Edited 24-Mar-87 18:30 by jds")

    (* ;; "Installs NEWCURSOR as the cursor and returns the old cursor state.  If INVERTFLG is non-NIL, the cursor image is inverted during installation.  If NEWCURSOR is NIL, just returns the current cursor state.")

    (DECLARE (GLOBALVARS DEFAULTCURSOR \SOFTCURSORP))
    (PROG (OLDCURSOR)
          (SETQ OLDCURSOR \CURRENTCURSOR)
          (COND
             ((EQ NEWCURSOR T)                               (* ; 
                                                "If NEWCURSOR is T, use the system default cursor.")

              (SETQ NEWCURSOR DEFAULTCURSOR)))
          (COND
             [(\CURSOR-VALID-P NEWCURSOR \SOFTCURSORP)   (* ; 
                                               "Only install the cursor if it's a real, valid one.")

              (\CURSORDOWN)
              (\CURSORUP NEWCURSOR INVERTFLG)            (* ; 
                         "set after adjustment to avoid confusion about hotspot during adjustment.")

              (SETQ \CURSORHOTSPOTX (fetch (CURSOR CUHOTSPOTX) of NEWCURSOR))
              (SETQ \CURSORHOTSPOTY (IDIFFERENCE (SUB1 (fetch (BITMAP BITMAPHEIGHT)
                                                          of (fetch (CURSOR CUIMAGE)
                                                                    of NEWCURSOR)))
                                           (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR]
             (NEWCURSOR                                      (* ; "NEWCURSOR = NIL means just return the old one, so only error if one got specified that wasn't valid.")

                    (\ILLEGAL.ARG NEWCURSOR)))
          (RETURN OLDCURSOR])
-
-(\CURSOR-VALID-P
  [LAMBDA (CURSOR SOFT?)                             (* ; "Edited 25-Mar-87 09:41 by jds")

    (* ;; "It returns T if CURSOR is a valid cursor.  Validity depends on whether it's meant to be displayed using the cursor hardware or the cursor software.")

    (* ;; "This is really wed to the D-machine display architecture. ")

    (AND (CURSORP CURSOR)
         (COND
            (SOFT? T)
            (T (LET ((IMAGE (fetch (CURSOR CUIMAGE) of CURSOR))
                     (HOTSPOT-X (fetch (CURSOR CUHOTSPOTX) of CURSOR))
                     (HOTSPOT-Y (fetch (CURSOR CUHOTSPOTY) of CURSOR)))
                    (* ;; "The bitmap must be <= 16x16, and the hot spot must be within the cursor if we're using hardware cursor.")

                    (AND (>= 16 (BITMAPWIDTH IMAGE))
                         (>= 16 (BITMAPHEIGHT IMAGE))
                         (<= 0 HOTSPOT-X)
                         (< HOTSPOT-X 16)
                         (<= 0 HOTSPOT-Y)
                         (< HOTSPOT-Y 16])
-
-(\CURSORUP
  [LAMBDA (NEWCURSOR INVERTFLG)                          (* kbr%: "18-Aug-85 14:38")
    (UNINTERRUPTABLY
        (\CURSORBITSPERPIXEL NEWCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL) of 
                                                                                   \CURSORDESTINATION
                                                  ))
        (COND
           ((AND (EQ (fetch (CURSOR CUIMAGE) of NEWCURSOR)
                     (fetch (CURSOR CUMASK) of NEWCURSOR))
                 (ILEQ (fetch (BITMAP BITMAPWIDTH) of (fetch (CURSOR CUIMAGE)
                                                                 of NEWCURSOR))
                       HARDCURSORWIDTH)
                 (ILEQ (fetch (BITMAP BITMAPHEIGHT) of (fetch (CURSOR CUIMAGE)
                                                                  of NEWCURSOR))
                       HARDCURSORHEIGHT)
                 (EQ \CURSORDESTINATION ScreenBitMap))
            (\HARDCURSORUP NEWCURSOR INVERTFLG))
           (T (\SOFTCURSORUP NEWCURSOR)))
        (ADJUSTCURSORPOSITION (IDIFFERENCE \CURSORHOTSPOTX (fetch (CURSOR CUHOTSPOTX)
                                                                  of NEWCURSOR))
               (IDIFFERENCE (IDIFFERENCE (SUB1 (fetch (BITMAP BITMAPHEIGHT)
                                                  of (fetch (CURSOR CUIMAGE) of
                                                                                         NEWCURSOR)))
                                   (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR))
                      \CURSORHOTSPOTY)))])
-
-(\CURSORPOSITION
  [LAMBDA (XPOS YPOS)                                    (* ; "Edited 19-Mar-98 14:41 by jds")

         (* sets cursor position, adjusts for hotspot and tty region limits.
       XPOS and YPOS are the screen coordinates of the hotspot location.)

    (DECLARE (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURSORDESTWIDTH \CURSORDESTHEIGHT))

         (* YPOS is reflected around CURSORYMAX because the screen has
       (0,0) as the upper left corner. *)

    (SETQ YPOS (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT)
                      YPOS))                                 (* Clip coordinates *)
    (SETQ XPOS (UNSIGNED (IDIFFERENCE (COND
                                         (NIL 
                                              (* ;; "Removed 2000/1/3 JDS so mousr cursors work.")

                                              (ILESSP XPOS 0)
                                              0)
                                         ((IGEQ XPOS \CURSORDESTWIDTH)
                                          (SUB1 \CURSORDESTWIDTH))
                                         (T XPOS))
                                \CURSORHOTSPOTX)
                      BITSPERWORD))
    (SETQ YPOS (UNSIGNED (IDIFFERENCE (COND
                                         (NIL (ILESSP YPOS 0)
                                              0)
                                         ((IGEQ YPOS \CURSORDESTHEIGHT)
                                          (SUB1 \CURSORDESTHEIGHT))
                                         (T YPOS))
                                \CURSORHOTSPOTY)
                      BITSPERWORD))
    [COND
       ((EQ \MACHINETYPE \DANDELION)                         (* Temporary workaround)
        (COND
           ((IGREATERP YPOS 32767)
            (SETQ YPOS 0)))
        (COND
           ((IGREATERP XPOS 32767)
            (SETQ XPOS 0]
    (\SETMOUSEXY XPOS YPOS)
    (COND
       (\SOFTCURSORP (\SOFTCURSORPOSITION XPOS YPOS)))
    [PROGN 

         (* change the cursor position too so that GETMOUSESTATE will get the correct 
       values if it is called before the next 60 cycle interrupt.)

           (\PUTBASE \EM.CURSORX 0 XPOS)
           (\PUTBASE \EM.CURSORY 0 YPOS)
           (COND
              ((EQ \MACHINETYPE \DAYBREAK)                   (* Need to notify DAYBREAK IOP to 
                                                           move cursor. *)
               (\DoveDisplay.SetCursorPosition XPOS YPOS]
    NIL])
-
-(\CURSORDOWN
  [LAMBDA NIL                                            (* kbr%: "12-Jun-85 17:21")
    (UNINTERRUPTABLY
        (COND
           (\SOFTCURSORP (\SOFTCURSORDOWN))
           (T (\HARDCURSORDOWN))))])
-
-(ADJUSTCURSORPOSITION
  [LAMBDA (DELTAX DELTAY)                                (* kbr%: " 6-Jan-86 11:55")
    (COND
       [(POSITIONP DELTAX)
        (\CURSORPOSITION (IPLUS (fetch (POSITION XCOORD) of DELTAX)
                                    (\XMOUSECOORD))
               (IPLUS (fetch (POSITION YCOORD) of DELTAX)
                      (\YMOUSECOORD]
       (T (\CURSORPOSITION (IPLUS (OR DELTAX 0)
                                      (\XMOUSECOORD))
                 (IPLUS (OR DELTAY 0)
                        (\YMOUSECOORD])
-
-(CURSORPOSITION
  [LAMBDA (NEWPOSITION DISPLAYSTREAM OLDPOSITION)        (* kbr%: "13-Feb-86 15:53")
    (PROG (DD)
          (SETQ DD (\GETDISPLAYDATA DISPLAYSTREAM))
          (OR (type? POSITION OLDPOSITION)
              (SETQ OLDPOSITION (create POSITION)))
          (freplace (POSITION XCOORD) of OLDPOSITION with (\DSPUNTRANSFORMX (\XMOUSECOORD
                                                                                         )
                                                                             DD))
          (freplace (POSITION YCOORD) of OLDPOSITION with (\DSPUNTRANSFORMY (\YMOUSECOORD
                                                                                         )
                                                                             DD))
          (COND
             ((type? POSITION NEWPOSITION)
              (\CURSORPOSITION (\DSPTRANSFORMX (fetch (POSITION XCOORD) of NEWPOSITION)
                                          DD)
                     (\DSPTRANSFORMY (fetch (POSITION YCOORD) of NEWPOSITION)
                            DD)))
             ((type? SCREENPOSITION NEWPOSITION)
              (CURSORSCREEN (fetch (SCREENPOSITION SCREEN) of NEWPOSITION)
                     (fetch (SCREENPOSITION XCOORD) of NEWPOSITION)
                     (fetch (SCREENPOSITION YCOORD) of NEWPOSITION)))
             (NEWPOSITION (\ILLEGAL.ARG NEWPOSITION)))
          (RETURN OLDPOSITION])
-
-(CURSORSCREEN
  [LAMBDA (SCREEN XCOORD YCOORD)                         (* gbn%: "25-Jan-86 16:53")
          (* * sets up SCREEN to be the current screen, XCOORD %, YCOORD is initial pos 
        of cursor on SCREEN)

    (COND
       ((NULL XCOORD)
        (SETQ XCOORD 0)))
    (COND
       ((NULL YCOORD)
        (SETQ YCOORD 0)))
    (PROG (DESTINATION)
          (SETQ DESTINATION (fetch (SCREEN SCDESTINATION) of SCREEN))
          (\CURSORDOWN)
          (SETQ \CURSORSCREEN SCREEN)
          (\CURSORDESTINATION DESTINATION)
          (\CURSORUP \CURRENTCURSOR)
          (\CURSORPOSITION XCOORD YCOORD])
-
-(CURSOREXIT
  [LAMBDA NIL                                            (* gbn%: "25-Jan-86 16:52")
          (* * called when cursor moves off the screen edge)

    (DECLARE (GLOBALVARS LASTSCREEN LASTMOUSEX LASTMOUSEY))
    (PROG (SCREEN XCOORD YCOORD SCREEN2 XCOORD2 YCOORD2)
          (SETQ SCREEN LASTSCREEN)
          (SETQ XCOORD LASTMOUSEX)
          (SETQ YCOORD LASTMOUSEY)
          (SETQ SCREEN2 (COND
                           ((EQ SCREEN \MAINSCREEN)
                            \COLORSCREEN)
                           (T \MAINSCREEN)))                 (* generalize for more than two 
                                                           screens (or alternate physical 
                                                           arrangement of screens.))
          (COND
             ((EQ XCOORD 0)
              (SETQ XCOORD2 (IDIFFERENCE (fetch (SCREEN SCWIDTH) of SCREEN2)
                                   2)))
             ((EQ XCOORD (SUB1 (fetch (SCREEN SCWIDTH) of SCREEN)))
              (SETQ XCOORD2 1))
             (T (RETURN)))
          [SETQ YCOORD2 (IQUOTIENT (ITIMES YCOORD (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN2))
                                          )
                               (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN]
          (CURSORSCREEN SCREEN2 XCOORD2 YCOORD2])
-
-(FLIPCURSOR
-  [LAMBDA NIL                                         (* ; "Edited 24-Apr-88 00:04 by MASINTER")
-    (PROG (ADDR)
-          (COND
-             ((NOT \SOFTCURSORP)
-              (SETQ ADDR \EM.CURSORBITMAP)
-              (FRPTQ HARDCURSORHEIGHT [\PUTBASE ADDR 0 (LOGXOR (\GETBASE ADDR 0)
-                                                              (CONSTANT (SUB1 (EXPT 2 HARDCURSORWIDTH
-                                                                                    ]
-                     (SETQ ADDR (\ADDBASE ADDR 1)))
-              (SELECTC \MACHINETYPE
-                  (\DAYBREAK (\DoveDisplay.SetCursorShape))
-                  (\MAIKO (AND \CURRENTCURSOR (SUBRCALL DSPCURSOR (fetch (CURSOR CUHOTSPOTX)
-                                                                     of \CURRENTCURSOR)
-                                                     (fetch (CURSOR CUHOTSPOTY) of 
-                                                                                       \CURRENTCURSOR
-                                                            ))))
-                  NIL])
-
-(FLIPCURSORBAR
-  [LAMBDA (N)                                            (* ; "Edited 19-Mar-98 14:23 by jds")
-
-(* ;;; "Inverts the Nth line of the cursor, N = 0 being the top")
-
-    (COND
-       ((NOT \SOFTCURSORP)
-        (\PUTBASE \EM.CURSORBITMAP N (LOGXOR (\GETBASE \EM.CURSORBITMAP N)
-                                            MAX.SMALLP))
-        (SELECTC \MACHINETYPE
-            (\DAYBREAK                                       (* ; "Notify IOP")
-                       (\DoveDisplay.SetCursorShape))
-            (\MAIKO (AND \CURRENTCURSOR (SUBRCALL DSPCURSOR (fetch (CURSOR CUHOTSPOTX)
-                                                               of \CURRENTCURSOR)
-                                               (fetch (CURSOR CUHOTSPOTY) of 
-                                                                                       \CURRENTCURSOR
-                                                      ))))
-            NIL])
-
-(LASTMOUSEX
  [LAMBDA (DS)                                           (* rmk%: "30-AUG-83 13:07")
          (* returns the mouse x position in the coordinates of the DisplayStream DS)

    (\DSPUNTRANSFORMX LASTMOUSEX (\GETDISPLAYDATA DS])
-
-(LASTMOUSEY
  [LAMBDA (DS)                                           (* rmk%: "30-AUG-83 13:07")
          (* returns the mouse y position in the coordinates of the DisplayStream DS)

    (\DSPUNTRANSFORMY LASTMOUSEY (\GETDISPLAYDATA DS])
-
-(CREATEPOSITION
  [LAMBDA (XCOORD YCOORD)                                (* rmk%: " 6-Aug-84 13:43")
    (create POSITION
           XCOORD _ (OR XCOORD 0)
           YCOORD _ (OR YCOORD 0])
-
-(POSITIONP
  [LAMBDA (X)                                            (* rrb "25-AUG-82 11:04")
          (* is X a position? For now just a cons check but should be made a datatype.)

    (AND (LISTP X)
         (NUMBERP (CAR X))
         (NUMBERP (CDR X))
         X])
-
-(CURSORHOTSPOT
  [LAMBDA (NEWPOSITION)                                  (* gbn%: "26-Jan-86 15:36")
          (* returns the current cursor hot spot and sets the hot spot to NEWPOSITON if 
        one is given.)

    (PROG1 (create POSITION
                  XCOORD _ \CURSORHOTSPOTX
                  YCOORD _ \CURSORHOTSPOTY)
           (COND
              ((POSITIONP NEWPOSITION)
               (SETQ \CURSORHOTSPOTX (fetch (POSITION YCOORD) of NEWPOSITION))
               (SETQ \CURSORHOTSPOTY (fetch (POSITION YCOORD) of NEWPOSITION])
-)
-
-(PUTPROPS CURSORPROP ARGNAMES (NIL (CURSOR PROP {NEWVALUE}) . U))
-
-(RPAQ? \CURSORHOTSPOTX 0)
-
-(RPAQ? \CURSORHOTSPOTY 0)
-
-(RPAQ? \CURRENTCURSOR NIL)
-
-(RPAQ? \SOFTCURSORWIDTH NIL)
-
-(RPAQ? \SOFTCURSORHEIGHT NIL)
-
-(RPAQ? \SOFTCURSORP NIL)
-
-(RPAQ? \SOFTCURSORUPP NIL)
-
-(RPAQ? \SOFTCURSORUPBM NIL)
-
-(RPAQ? \SOFTCURSORDOWNBM NIL)
-
-(RPAQ? \SOFTCURSORBBT1 NIL)
-
-(RPAQ? \SOFTCURSORBBT2 NIL)
-
-(RPAQ? \SOFTCURSORBBT3 NIL)
-
-(RPAQ? \SOFTCURSORBBT4 NIL)
-
-(RPAQ? \SOFTCURSORBBT5 NIL)
-
-(RPAQ? \SOFTCURSORBBT6 NIL)
-
-(RPAQ? \CURSORSCREEN NIL)
-
-(RPAQ? \CURSORDESTINATION NIL)
-
-(RPAQ? \CURSORDESTHEIGHT 808)
-
-(RPAQ? \CURSORDESTWIDTH 1024)
-
-(RPAQ? \CURSORDESTRASTERWIDTH 64)
-
-(RPAQ? \CURSORDESTLINE 0)
-
-(RPAQ? \CURSORDESTLINEBASE NIL)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH \SOFTCURSORHEIGHT 
-       \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2
-       \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 \CURSORDESTINATION 
-       \CURSORDESTHEIGHT \CURSORDESTWIDTH \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE)
-)
-(DEFINEQ
-
-(GETMOUSESTATE
  [LAMBDA NIL                                            (* kbr%: " 6-Jul-85 14:16")
                                                             (* Reads the current state of the 
                                                           mouse and keyboard)
    (SETQ LASTMOUSEX (\XMOUSECOORD))
    (SETQ LASTMOUSEY (\YMOUSECOORD))
    (SETQ LASTMOUSEBUTTONS (LOGXOR (LOGAND (fetch (KEYBOARDEVENT WU) of \LASTKEYSTATE)
                                          \MOUSE.ALLBITS)
                                  \MOUSE.ALLBITS))
    (SETQ LASTKEYBOARD (\EVENTKEYS))
    (SETQ LASTSCREEN \CURSORSCREEN)
    NIL])
-
-(\EVENTKEYS
  [LAMBDA NIL                                            (* rmk%: " 4-JUN-81 22:58")
          (* Returns the state of the various keys that are represented in mouse events)

    (LOGOR (COND
              ((KEYDOWNP 'LOCK)
               128)
              (T 0))
           (COND
              ((KEYDOWNP 'LSHIFT)
               64)
              (T 0))
           (COND
              ((KEYDOWNP 'CTRL)
               32)
              (T 0))
           (COND
              ((KEYDOWNP 'RSHIFT)
               8)
              (T 0))
           (COND
              ((KEYDOWNP 'BLANK-TOP)
               4)
              (T 0))
           (COND
              ((KEYDOWNP 'BLANK-MIDDLE)
               2)
              (T 0))
           (COND
              ((KEYDOWNP 'BLANK-BOTTOM)
               1)
              (T 0])
-)
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ HARDCURSORHEIGHT 16)
-
-(RPAQQ HARDCURSORWIDTH 16)
-
-
-(CONSTANTS (HARDCURSORHEIGHT 16)
-       (HARDCURSORWIDTH 16))
-)
-(DECLARE%: EVAL@COMPILE 
-
-(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD)
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-(DECLARE%: DONTCOPY 
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
-
-[PUTPROPS \SETMOUSEXY MACRO ((XPOS YPOS)
-                             (PROGN (SELECTC \MACHINETYPE
-                                        (\DAYBREAK (\DoveMisc.SetMousePosition XPOS YPOS))
-                                        (\MAIKO (SUBRCALL SETMOUSEXY XPOS YPOS))
-                                        (\DANDELION (do (PROGN (replace (IOPAGE NEWMOUSEX)
-                                                                      of \IOPAGE with XPOS)
-                                                                   (replace (IOPAGE NEWMOUSEY)
-                                                                      of \IOPAGE with YPOS))
-                                                       repeatuntil (ILESSP (fetch
-                                                                                (IOPAGE NEWMOUSESTATE
-                                                                                       ) of
-                                                                                         \IOPAGE)
-                                                                              32768))
-                                                             (* ; 
-                                                   "smash position until mouse says it is not busy")
-                                                    (replace (IOPAGE NEWMOUSEX) of \IOPAGE
-                                                       with XPOS)
-                                                    (replace (IOPAGE NEWMOUSEY) of \IOPAGE
-                                                       with YPOS)
-                                                    (replace (IOPAGE NEWMOUSESTATE) of 
-                                                                                              \IOPAGE
-                                                       with 32768))
-                                        NIL)
-                                    (PROGN (\PUTBASE \EM.MOUSEX 0 XPOS)
-                                           (\PUTBASE \EM.MOUSEY 0 YPOS]
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-
-(DECLARE%: EVAL@COMPILE 
-
-[PUTPROPS \XMOUSECOORD MACRO (NIL (IPLUS \CURSORHOTSPOTX (SIGNED (\GETBASE \EM.CURSORX 0)
-                                                                BITSPERWORD]
-
-[PUTPROPS \YMOUSECOORD MACRO (NIL (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT)
-                                         (IPLUS \CURSORHOTSPOTY (SIGNED (\GETBASE \EM.CURSORY 0)
-                                                                       BITSPERWORD]
-)
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(MOVD 'CURSOR 'SETCURSOR)
-
-(MOVD '\CURSORPOSITION '\SETCURSORPOSITION)
-
-
-(RPAQ \SFPosition (CREATEPOSITION))
-)
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(BLOCKRECORD KEYBOARDEVENT 
-             ((W0 WORD)
-              (W1 WORD)
-              (W2 WORD)
-              (W3 WORD)
-              (WU WORD)
-              (W4 WORD)
-              (W5 WORD)
-              (TIME FIXP)
-              (MOUSESTATE BITS 3)
-              (1SHIFT FLAG)
-              (2SHIFT FLAG)
-              (LOCK FLAG)
-              (CTRL FLAG)
-              (META FLAG)
-              (FONT FLAG)
-              (USERMODE1 FLAG)
-              (USERMODE2 FLAG)
-              (USERMODE3 FLAG)
-              (ALTGRAPH FLAG)
-              (DEADKEYPENDING FLAG)                          (* ; "T if the last key was a dead (accent) key, and we should generate an accented character if possible.")
-              (NIL BITS 2)
-              (MOUSEX WORD)
-              (MOUSEY WORD)
-              (DEADKEY-ALIST XPOINTER)                       (* ; 
-                                    "The ALIST describing accents possible from teh last dead key.")
-              )
-             (CREATE (\ALLOCBLOCK (FOLDHI \KEYBOARDEVENT.SIZE WORDSPERCELL)))
-             W0 _ ALLUP W1 _ ALLUP W2 _ ALLUP W3 _ ALLUP W4 _ ALLUP W5 _ ALLUP WU _ ALLUP MOUSESTATE
-             _ \DLMOUSE.UP [ACCESSFNS KEYBOARDEVENT ((SIZE (INDEXF (fetch MOUSEY of DATUM)))
-                                                     (SHIFT (OR (fetch (KEYBOARDEVENT 1SHIFT)
-                                                                       DATUM)
-                                                                (fetch (KEYBOARDEVENT 2SHIFT)
-                                                                       DATUM)))
-                                                     (SHIFTORLOCK (OR (fetch (KEYBOARDEVENT
-                                                                                  SHIFT)
-                                                                             DATUM)
-                                                                      (fetch (KEYBOARDEVENT
-                                                                                  LOCK)
-                                                                             DATUM]
-             LOCK _ (XKEYDOWNP 'LOCK)
-             TIME _ 0 DEADKEYPENDING _ NIL)
-)
-
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQ \KEYBOARDEVENT.FIRST NRINGINDEXWORDS)
-
-(RPAQQ \KEYBOARDEVENT.SIZE 14)
-
-(RPAQ \KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383)))
-
-
-[CONSTANTS (\KEYBOARDEVENT.FIRST NRINGINDEXWORDS)
-       \KEYBOARDEVENT.SIZE
-       (\KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383]
-)
-)
-(DEFINEQ
-
-(MACHINETYPE
  [LAMBDA NIL                                            (* ; "Edited 30-Mar-88 10:27 by Snow")

    (SELECTC (fetch MachineType of \InterfacePage)
        (\DORADO 'DORADO)
        (\DANDELION 'DANDELION)
        (\DAYBREAK                                           (* This is \DAYBREAK internally)
                   'DOVE)
        (\MAIKO 'MAIKO)
        NIL])
-
-(SETMAINTPANEL
  [LAMBDA (N)                                            (* mpl "21-Jul-85 18:15")
    (SELECTC \MACHINETYPE
        (\DANDELION (replace DLMAINTPANEL of \IOPAGE with N))
        (\DOLPHIN ((OPCODES MISC1 3)
                   (\DTEST N 'SMALLP)))
        (\DAYBREAK ((OPCODES DOVEMISC 2)
                    (\DTEST N 'SMALLP)))
        NIL])
-)
-
-
-
-(* ; "DLion beeper")
-
-(DEFINEQ
-
-(BEEPON
  [LAMBDA (FREQ)                                      (* ; "Edited 10-May-88 18:17 by MASINTER")
    (SELECTC \MACHINETYPE
        (\DANDELION (while (IGEQ (fetch DLBEEPCMD of \IOPAGE)
                                     32768) do (BLOCK))
                    (replace DLBEEPFREQ of \IOPAGE with (IQUOTIENT 1843200
                                                                           (IMAX FREQ 29)))
                    (replace DLBEEPCMD of \IOPAGE with 32768))
        (\DAYBREAK (\DoveMisc.BeepOn FREQ))
        (\MAIKO (SUBRCALL KEYBOARDBEEP T FREQ))
        (PROGN NIL))
    NIL])
-
-(BEEPOFF
  [LAMBDA NIL                                         (* ; "Edited 10-May-88 18:17 by MASINTER")
    (SELECTC \MACHINETYPE
        (\DANDELION (while (IGEQ (fetch DLBEEPCMD of \IOPAGE)
                                     32768) do (BLOCK))
                    (replace DLBEEPCMD of \IOPAGE with 32769))
        (\DAYBREAK (\DoveMisc.BeepOff))
        (\MAIKO (SUBRCALL KEYBOARDBEEP NIL NIL))
        (PROGN NIL))
    NIL])
-)
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0 
-       \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 \EM.KBDAD5 \EM.DISPINTERRUPT \EM.DISPLAYHEAD 
-       \EM.CURSORBITMAP \MACHINETYPE \DEFAULTKEYACTION \COMMANDKEYACTION \CURRENTKEYACTION 
-       \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY)
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-(DEFINEQ
-
-(WITHOUT-INTERRUPTS
  [NLAMBDA (FORM)                                        (* lmm "18-Apr-85 02:53")
    (PROG (VAL)
          (\KEYBOARDOFF)
          (SETQ VAL (DISPLAYDOWN FORM))
          (\KEYBOARDON)
          (RETURN VAL])
-)
-
-
-
-(* ; "Compile locked fns together for locality")
-
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
-
-(BLOCK%: NIL FLIPCURSORBAR \KEYHANDLER \KEYHANDLER1 \TRACKCURSOR \PERIODIC.INTERRUPTFRAME 
-       \TIMER.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS \DOTRANSITIONS \DECODETRANSITION \EVENTKEYS 
-       \HARDCURSORUP \DOMOUSECHORDING \KEYBOARDOFF \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP
-       \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN)
-)
-(DECLARE%: DONTCOPY 
-
-(ADDTOVAR INEWCOMS 
-          (ALLOCAL (ADDVARS (LOCKEDFNS FLIPCURSORBAR \SETIOPOINTERS \KEYHANDLER \KEYHANDLER1 
-                                   \CONTEXTAPPLY \LOCKPAGES \DECODETRANSITION \SMASHLINK \INCUSECOUNT
-                                   LLSH \MAKEFREEBLOCK \DECUSECOUNT \MAKENUMBER \ADDBASE 
-                                   \PERIODIC.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS 
-                                   \TIMER.INTERRUPTFRAME \CAUSEINTERRUPT \DOMOUSECHORDING 
-                                   \KEYBOARDOFF \TRACKCURSOR \HARDCURSORUP \HARDCURSORPOSITION 
-                                   \HARDCURSORDOWN \SOFTCURSORUP \SOFTCURSORUPCURRENT 
-                                   \SOFTCURSORPOSITION \SOFTCURSORDOWN \SOFTCURSORPILOTBITBLT)
-                          (LOCKEDVARS \InterfacePage \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR 
-                                 \SOFTCURSORWIDTH \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP 
-                                 \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2 
-                                 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 
-                                 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH 
-                                 \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE 
-                                 \PENDINGINTERRUPT \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY
-                                 \LASTUSERACTION \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING 
-                                 SCREENWIDTH SCREENHEIGHT \TIMER.INTERRUPT.PENDING \EM.MOUSEX 
-                                 \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN 
-                                 \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.DISPINTERRUPT 
-                                 \EM.CURSORBITMAP \EM.KBDAD4 \EM.KBDAD5 \MISCSTATS \RCLKSECOND))))
-
-(ADDTOVAR RDCOMS (FNS \SETIOPOINTERS))
-)
-
-(PUTPROPS LLKEY FILETYPE CL:COMPILE-FILE)
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML WITHOUT-INTERRUPTS)
-
-(ADDTOVAR LAMA CURSORPROP METASHIFT MOUSECHORDWAIT)
-)
-(PUTPROPS LLKEY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 1990 
-1992 1999 1920 2000))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (14769 21865 (BKSYSCHARCODE 14779 . 15128) (\CLEARSYSBUF 15130 . 15688) (\GETKEY 15690
- . 16865) (\NSYSBUFCHARS 16867 . 17507) (\SAVESYSBUF 17509 . 19121) (\SYSBUFP 19123 . 19427) (
-\GETSYSBUF 19429 . 19609) (\PUTSYSBUF 19611 . 20825) (\PEEKSYSBUF 20827 . 21863)) (23123 59302 (
-\KEYBOARDINIT 23133 . 24856) (\KEYBOARDEVENTFN 24858 . 29558) (\ALLOCLOCKED 29560 . 30150) (
-\SETIOPOINTERS 30152 . 34621) (\KEYBOARDOFF 34623 . 34970) (\KEYBOARDON 34972 . 35284) (\KEYHANDLER 
-35286 . 35417) (\KEYHANDLER1 35419 . 42737) (\RESETKEYBOARD 42739 . 44248) (\DOMOUSECHORDING 44250 . 
-47921) (\DOTRANSITIONS 47923 . 48600) (\DECODETRANSITION 48602 . 55291) (MOUSECHORDWAIT 55293 . 55976)
- (\TRACKCURSOR 55978 . 59300)) (101704 125063 (KEYACTION 101714 . 102558) (KEYACTIONTABLE 102560 . 
-103742) (KEYBOARDTYPE 103744 . 104846) (RESETKEYACTION 104848 . 106607) (
-\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS 106609 . 110016) (\KEYACTION1 110018 . 120639) (KEYDOWNP 120641
- . 120976) (KEYNUMBERP 120978 . 121176) (\KEYNAMETONUMBER 121178 . 121872) (MODIFY.KEYACTIONS 121874
- . 122735) (METASHIFT 122737 . 123681) (SHIFTDOWNP 123683 . 125061)) (125126 125422 (
-SETUP.OFFICE.KEYBOARD 125136 . 125420)) (128845 130557 (\INIT.KEYBOARD.STREAM 128855 . 130555)) (
-130822 147199 (\DOBUFFEREDTRANSITIONS 130832 . 146262) (\TIMER.INTERRUPTFRAME 146264 . 146989) (
-\PERIODIC.INTERRUPTFRAME 146991 . 147197)) (147453 151530 (\HARDCURSORUP 147463 . 149345) (
-\HARDCURSORPOSITION 149347 . 151383) (\HARDCURSORDOWN 151385 . 151528)) (151531 175591 (CURSOR.INIT 
-151541 . 155241) (\CURSORDESTINATION 155243 . 157561) (\SOFTCURSORUP 157563 . 162817) (
-\SOFTCURSORUPCURRENT 162819 . 169855) (\SOFTCURSORPOSITION 169857 . 170622) (\SOFTCURSORDOWN 170624 . 
-171332) (CURSORPROP 171334 . 171676) (GETCURSORPROP 171678 . 171866) (PUTCURSORPROP 171868 . 173023) (
-\CURSORBITSPERPIXEL 173025 . 175141) (\CURSORIMAGEPROPNAME 175143 . 175367) (\CURSORMASKPROPNAME 
-175369 . 175589)) (175592 193542 (CURSORCREATE 175602 . 178277) (CURSOR 178279 . 180091) (
-\CURSOR-VALID-P 180093 . 181180) (\CURSORUP 181182 . 182897) (\CURSORPOSITION 182899 . 185427) (
-\CURSORDOWN 185429 . 185662) (ADJUSTCURSORPOSITION 185664 . 186242) (CURSORPOSITION 186244 . 187786) (
-CURSORSCREEN 187788 . 188444) (CURSOREXIT 188446 . 189837) (FLIPCURSOR 189839 . 190965) (FLIPCURSORBAR
- 190967 . 191947) (LASTMOUSEX 191949 . 192203) (LASTMOUSEY 192205 . 192459) (CREATEPOSITION 192461 . 
-192667) (POSITIONP 192669 . 192953) (CURSORHOTSPOT 192955 . 193540)) (194776 196324 (GETMOUSESTATE 
-194786 . 195445) (\EVENTKEYS 195447 . 196322)) (202185 202981 (MACHINETYPE 202195 . 202595) (
-SETMAINTPANEL 202597 . 202979)) (203011 204150 (BEEPON 203021 . 203674) (BEEPOFF 203676 . 204148)) (
-204601 204864 (WITHOUT-INTERRUPTS 204611 . 204862)))))
-STOP
diff --git a/sources/LLKEY.~4~ b/sources/LLKEY.~4~
deleted file mode 100644
index 04a57a3d..00000000
--- a/sources/LLKEY.~4~
+++ /dev/null
@@ -1,35 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-May-2018 13:32:12" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LLKEY.;4 199267 

      changes to%:  (VARS LLKEYCOMS \KEYNAMES)

      previous date%: " 9-Apr-2000 16:28:23" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>LLKEY.;1)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992, 1999, 1920, 2000, 2018 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT LLKEYCOMS)

(RPAQQ LLKEYCOMS
       [(COMS                                                (* ; "Access to keyboard")
              (FNS BKSYSCHARCODE \CLEARSYSBUF \GETKEY \NSYSBUFCHARS \SAVESYSBUF \SYSBUFP \GETSYSBUF 
                   \PUTSYSBUF \PEEKSYSBUF)
              (INITVARS (\LONGSYSBUF))
              (INITVARS (\\KEYBOARDWAITBOX.GLOBALRESOURCE))
              (DECLARE%: DONTCOPY (RESOURCES \KEYBOARDWAITBOX))
              (DECLARE%: DONTCOPY (CONSTANTS (\SYSBUFSIZE 200))
                     (MACROS \GETREALSYSBUF)))
        [DECLARE%: DOCOPY DONTEVAL@LOAD (COMS                (* ; 
                                          "Here because it must be done in init before PROC loaded")
                                              (P (MOVD? 'NILL 'CARET]
        (COMS                                                (* ; "Key handler")
              (FNS \KEYBOARDINIT \KEYBOARDEVENTFN \ALLOCLOCKED \SETIOPOINTERS \KEYBOARDOFF 
                   \KEYBOARDON \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD \DOMOUSECHORDING 
                   \DOTRANSITIONS \DECODETRANSITION MOUSECHORDWAIT \TRACKCURSOR)
              (CONSTANTS (\SUN.TYPE3KEYBOARD 0)
                     (\SUN.TYPE4KEYBOARD 1)
                     (\SUN.JLEKEYBOARD 2)
                     (\TOSHIBA.JIS 7))
              (INITVARS (\MOUSECHORDTICKS)
                     (\MOUSECHORDMILLISECONDS 50))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\KEYBOARDINIT)))
              [DECLARE%: DONTCOPY (MACROS .NOTELASTUSERACTION)
                     (CONSTANTS ALLUP \CTRLMASK \METABIT)
                     (CONSTANTS * DLMOUSEBITS)
                     (CONSTANTS * DLMOUSESTATES)
                     (CONSTANTS * TRANSITIONFLAGS)
                     (MACROS \TRANSINDEX ARMEDCODE TRANSITIONALTGRCODE TRANSITIONSHIFTCODE 
                            TRANSITIONCODE TRANSITIONFLAGS TRANSITIONDEADLIST CHECKFORDEADKEY)
                     (EXPORT (RECORDS KEYACTION)
                            (CONSTANTS \NKEYS))
                     (RECORDS RING)
                     (COMS                                   (* ; 
                                          "can get rid of shiftstate after clients have been fixed")
                           (RECORDS SHIFTSTATE)
                           (GLOBALVARS \SHIFTSTATE \MOUSETIMERTEMP))
                     (CONSTANTS NRINGINDEXWORDS)
                     (CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
                            (\SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE]
              (DECLARE%: EVAL@COMPILE (VARS \KEYNAMES))
              
              (* ;; "\maikokeyactions does not contain keyactions of the form %"2,50%" because it breaks the loadup process on the sun.")

              (VARS \ORIGKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DORADOKEYACTIONS 
                    \DOVEKEYACTIONS \DOVEOSDKEYACTIONS \MAIKOKEYACTIONS \MAIKOKEYACTIONST4 
                    \MAIKO-JLE-KEYACTIONS \TOSHIBA-KEYACTIONS)
              (VARS (KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS NIL))
              (INITVARS (\KEYBOARD.META 256)
                     (\MODIFIED.KEYACTIONS))
              (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS \RCLKSECOND \LASTUSERACTION \LASTKEYSTATE)
                                             ))
              (GLOBALVARS \SYSBUFFER \LONGSYSBUF \INTERRUPTSTATE \MODIFIED.KEYACTIONS 
                     \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING \CURRENTKEYACTION 
                     \COMMANDKEYACTION \DEFAULTKEYACTION \TIMER.INTERRUPT.PENDING \ORIGKEYACTIONS 
                     \KEYBOARD.META \MOUSECHORDMILLISECONDS \DORADOKEYACTIONS \DLIONKEYACTIONS 
                     \DLIONOSDKEYACTIONS \DOVEKEYACTIONS \DOVEOSDKEYACTIONS))
        (COMS                                                (* ; "Key interpretation")
              (FNS KEYACTION KEYACTIONTABLE KEYBOARDTYPE RESETKEYACTION 
                   \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS \KEYACTION1 KEYDOWNP KEYNUMBERP 
                   \KEYNAMETONUMBER MODIFY.KEYACTIONS METASHIFT SHIFTDOWNP)
                                                             (* ; 
                                                    "To support office style 1108 & 1186 keyboards")
              (FNS SETUP.OFFICE.KEYBOARD)
              (OPTIMIZERS \KEYNAMETONUMBER)
              (MACROS \TEMPCOPYTIMER)
                                                             (* ; 
                  "Don't copy this optimizer since it expands out to \getbasebit, but do exportit.")
              (DECLARE%: DONTCOPY (EXPORT (OPTIMIZERS KEYDOWNP)))
              (EXPORT (MACROS XKEYDOWNP KEYDOWNP1 \NEWKEYDOWNP)))
        (COMS                                                (* ; "A raw keyboard device/stream")
              (FNS \INIT.KEYBOARD.STREAM)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\INIT.KEYBOARD.STREAM)))
              (EXPORT (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM)))
        (COMS                                                (* ; "Hook for a periodic interrupt")
              (FNS \DOBUFFEREDTRANSITIONS \TIMER.INTERRUPTFRAME \PERIODIC.INTERRUPTFRAME)
              (INITVARS (\KEYBUFFERING)
                     (\PERIODIC.INTERRUPT)
                     (\TIMER.INTERRUPT.PENDING)
                     (\PERIODIC.INTERRUPT.FREQUENCY 77)))
        (LOCALVARS . T)
        [COMS                                                (* ; 
                                                           "cursor and mouse related functions.")
              (FNS \HARDCURSORUP \HARDCURSORPOSITION \HARDCURSORDOWN)
              (FNS CURSOR.INIT \CURSORDESTINATION \SOFTCURSORUP \SOFTCURSORUPCURRENT 
                   \SOFTCURSORPOSITION \SOFTCURSORDOWN CURSORPROP GETCURSORPROP PUTCURSORPROP 
                   \CURSORBITSPERPIXEL \CURSORIMAGEPROPNAME \CURSORMASKPROPNAME)
              (FNS CURSORCREATE CURSOR \CURSOR-VALID-P \CURSORUP \CURSORPOSITION \CURSORDOWN 
                   ADJUSTCURSORPOSITION CURSORPOSITION CURSORSCREEN CURSOREXIT FLIPCURSOR 
                   FLIPCURSORBAR LASTMOUSEX LASTMOUSEY CREATEPOSITION POSITIONP CURSORHOTSPOT)
              (PROPS (CURSORPROP ARGNAMES))
              (INITVARS (\CURSORHOTSPOTX 0)
                     (\CURSORHOTSPOTY 0)
                     (\CURRENTCURSOR NIL)
                     (\SOFTCURSORWIDTH NIL)
                     (\SOFTCURSORHEIGHT NIL)
                     (\SOFTCURSORP NIL)
                     (\SOFTCURSORUPP NIL)
                     (\SOFTCURSORUPBM NIL)
                     (\SOFTCURSORDOWNBM NIL)
                     (\SOFTCURSORBBT1 NIL)
                     (\SOFTCURSORBBT2 NIL)
                     (\SOFTCURSORBBT3 NIL)
                     (\SOFTCURSORBBT4 NIL)
                     (\SOFTCURSORBBT5 NIL)
                     (\SOFTCURSORBBT6 NIL)
                     (\CURSORSCREEN NIL)
                     (\CURSORDESTINATION NIL)
                     (\CURSORDESTHEIGHT 808)
                     (\CURSORDESTWIDTH 1024)
                     (\CURSORDESTRASTERWIDTH 64)
                     (\CURSORDESTLINE 0)
                     (\CURSORDESTLINEBASE NIL))
              (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH 
                     \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM
                     \SOFTCURSORBBT1 \SOFTCURSORBBT2 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5
                     \SOFTCURSORBBT6 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH 
                     \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE)
              (FNS GETMOUSESTATE \EVENTKEYS)
              [EXPORT (CONSTANTS (HARDCURSORHEIGHT 16)
                             (HARDCURSORWIDTH 16))
                     (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN 
                                                             LASTMOUSEBUTTONS LASTMOUSETIME 
                                                             LASTKEYBOARD]
              (DECLARE%: DONTCOPY (EXPORT (MACROS \SETMOUSEXY))
                     (MACROS \XMOUSECOORD \YMOUSECOORD))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'CURSOR 'SETCURSOR)
                                                 (MOVD '\CURSORPOSITION '\SETCURSORPOSITION))
                     (VARS (\SFPosition (CREATEPOSITION]
        [COMS (DECLARE%: DONTCOPY (RECORDS KEYBOARDEVENT)
                     (CONSTANTS (\KEYBOARDEVENT.FIRST NRINGINDEXWORDS)
                            \KEYBOARDEVENT.SIZE
                            (\KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES 
                                                                                  \KEYBOARDEVENT.SIZE
                                                                                   383]
        (COMS (FNS MACHINETYPE SETMAINTPANEL)
                                                             (* ; "DLion beeper")
              (FNS BEEPON BEEPOFF))
        (EXPORT (GLOBALVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN 
                       \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 \EM.KBDAD5 
                       \EM.DISPINTERRUPT \EM.DISPLAYHEAD \EM.CURSORBITMAP \MACHINETYPE 
                       \DEFAULTKEYACTION \COMMANDKEYACTION \CURRENTKEYACTION \PERIODIC.INTERRUPT 
                       \PERIODIC.INTERRUPT.FREQUENCY))
        (FNS WITHOUT-INTERRUPTS)
        (COMS                                                (* ; 
                                                         "Compile locked fns together for locality")
              (BLOCKS (NIL FLIPCURSORBAR \KEYHANDLER \KEYHANDLER1 \TRACKCURSOR 
                           \PERIODIC.INTERRUPTFRAME \TIMER.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS 
                           \DOTRANSITIONS \DECODETRANSITION \EVENTKEYS \HARDCURSORUP \DOMOUSECHORDING
                           \KEYBOARDOFF \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP 
                           \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN)))
        [DECLARE%: DONTCOPY
               (ADDVARS [INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS FLIPCURSORBAR \SETIOPOINTERS 
                                                           \KEYHANDLER \KEYHANDLER1 \CONTEXTAPPLY 
                                                           \LOCKPAGES \DECODETRANSITION \SMASHLINK 
                                                           \INCUSECOUNT LLSH \MAKEFREEBLOCK 
                                                           \DECUSECOUNT \MAKENUMBER \ADDBASE 
                                                           \PERIODIC.INTERRUPTFRAME 
                                                           \DOBUFFEREDTRANSITIONS 
                                                           \TIMER.INTERRUPTFRAME \CAUSEINTERRUPT 
                                                           \DOMOUSECHORDING \KEYBOARDOFF \TRACKCURSOR
                                                           \HARDCURSORUP \HARDCURSORPOSITION 
                                                           \HARDCURSORDOWN \SOFTCURSORUP 
                                                           \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION 
                                                           \SOFTCURSORDOWN \SOFTCURSORPILOTBITBLT)
                                                  (LOCKEDVARS \InterfacePage \CURSORHOTSPOTX 
                                                         \CURSORHOTSPOTY \CURRENTCURSOR 
                                                         \SOFTCURSORWIDTH \SOFTCURSORHEIGHT 
                                                         \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM
                                                         \SOFTCURSORDOWNBM \SOFTCURSORBBT1 
                                                         \SOFTCURSORBBT2 \SOFTCURSORBBT3 
                                                         \SOFTCURSORBBT4 \SOFTCURSORBBT5 
                                                         \SOFTCURSORBBT6 \CURSORDESTINATION 
                                                         \CURSORDESTHEIGHT \CURSORDESTWIDTH 
                                                         \CURSORDESTRASTERWIDTH \CURSORDESTLINE 
                                                         \CURSORDESTLINEBASE \PENDINGINTERRUPT 
                                                         \PERIODIC.INTERRUPT 
                                                         \PERIODIC.INTERRUPT.FREQUENCY 
                                                         \LASTUSERACTION \MOUSECHORDTICKS 
                                                         \KEYBOARDEVENTQUEUE \KEYBUFFERING 
                                                         SCREENWIDTH SCREENHEIGHT 
                                                         \TIMER.INTERRUPT.PENDING \EM.MOUSEX 
                                                         \EM.MOUSEY \EM.CURSORX \EM.CURSORY 
                                                         \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0 
                                                         \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 
                                                         \EM.DISPINTERRUPT \EM.CURSORBITMAP 
                                                         \EM.KBDAD4 \EM.KBDAD5 \MISCSTATS \RCLKSECOND
                                                         ]
                      (RDCOMS (FNS \SETIOPOINTERS]
        (PROP FILETYPE LLKEY)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML 
                                                                                   WITHOUT-INTERRUPTS
                                                                                    )
                                                                             (LAMA CURSORPROP 
                                                                                   METASHIFT 
                                                                                   MOUSECHORDWAIT])



(* ; "Access to keyboard")

(DEFINEQ

(BKSYSCHARCODE
  [LAMBDA (CHAR)                                         (* rrb "30-Dec-83 11:56")
    (OR (\PUTSYSBUF CHAR)
        (PROGN (SETQ \LONGSYSBUF (NCONC \LONGSYSBUF (bind C while (SETQ C (\GETREALSYSBUF))
                                                       collect C)))
               (\PUTSYSBUF CHAR])

(\CLEARSYSBUF
  [LAMBDA (ALLFLG)                                       (* mpl "27-Jun-85 20:04")
    (DECLARE (GLOBALVARS \PROCESSES))
    (COND
       ((OR ALLFLG (TTY.PROCESSP))
        (SETQ \LONGSYSBUF)
        (replace (RING READ) of \SYSBUFFER with 0)))
    (COND
       (ALLFLG (for PROC in \PROCESSES do (replace PROCTYPEAHEAD of PROC
                                                         with NIL)))
       ((THIS.PROCESS)
        (replace PROCTYPEAHEAD of (THIS.PROCESS) with NIL])

(\GETKEY
  [LAMBDA NIL                                            (* lmm "18-Apr-85 00:07")
    (DECLARE (GLOBALVARS \KEYBOARDWAIT1 \KEYBOARDWAIT2))
    (COND
       [(AND (THIS.PROCESS)
             (fetch PROCTYPEAHEAD of (THIS.PROCESS)))
        (pop (fetch PROCTYPEAHEAD of (THIS.PROCESS]
       (T (WAIT.FOR.TTY)
          (OR (\GETSYSBUF)
              (GLOBALRESOURCE (\KEYBOARDWAITBOX)             (* Busy-wait loop that gets next 
                                                           character)
                     (\CLOCK0 \KEYBOARDWAITBOX)
                     (bind C do (COND
                                           ((SETQ C (\GETSYSBUF))
                                            (\BOXIPLUS (LOCF (fetch KEYBOARDWAITTIME of
                                                                                         \MISCSTATS))
                                                   (CLOCKDIFFERENCE \KEYBOARDWAITBOX))
                                            (RETURN C)))
                                       (\TTYBACKGROUND)
                                       (\WAIT.FOR.TTY])

(\NSYSBUFCHARS
  [LAMBDA NIL                                            (* JonL " 7-May-84 01:50")
          (* Tells how many characters can be \GETSYSBUFed.
        Used by \SAVESYSBUF.)

    (IPLUS (LENGTH \LONGSYSBUF)
           (PROG ((R (fetch (RING READ) of \SYSBUFFER))
                  (W (fetch (RING WRITE) of \SYSBUFFER)))
                 (RETURN (COND
                            ((EQ 0 R)
                             0)
                            ((IGREATERP W R)
                             (IDIFFERENCE W R))
                            (T (IDIFFERENCE W (IDIFFERENCE R \SYSBUFSIZE])

(\SAVESYSBUF
  [LAMBDA NIL                                            (* JonL " 7-May-84 01:50")
    (DECLARE (GLOBALVARS \SAVEDSYSBUFFER))
    (PROG (TA (BUF \SAVEDSYSBUFFER)
              (NC (\NSYSBUFCHARS))
              (J 0))
          [COND
             ((TTY.PROCESSP)
              [COND
                 ([AND (THIS.PROCESS)
                       (SETQ TA (fetch PROCTYPEAHEAD of (THIS.PROCESS]
                  (replace PROCTYPEAHEAD of (THIS.PROCESS) with NIL)
                  (add NC (LENGTH TA))
                  [COND
                     ((IGREATERP NC (NCHARS BUF))
                      (SETQ BUF (ALLOCSTRING NC]
                  (for CH in TA do (RPLCHARCODE BUF (add J 1)
                                                      CH)))
                 ((IGREATERP NC (NCHARS BUF))
                  (SETQ BUF (ALLOCSTRING NC]
              (for I from (ADD1 J) to NC do 
          (* Test on J means that we'll ignore extra chars typed since we got the 
        length. Test on \GETSYSBUF so we don't get screwed if buffer gets cleared 
        while during this loop)

                                                           (RPLCHARCODE BUF I
                                                                  (OR (\GETSYSBUF)
                                                                      (PROGN (SETQ NC (SUB1 I))
                                                                             (RETURN]
          (RETURN (AND (NOT (EQ 0 NC))
                       (SUBSTRING BUF 1 NC])

(\SYSBUFP
  [LAMBDA NIL                                            (* JonL " 7-May-84 01:52")
    (OR [AND (TTY.PROCESSP)
             (OR \LONGSYSBUF (NOT (EQ 0 (fetch (RING READ) of \SYSBUFFER]
        (AND (THIS.PROCESS)
             (fetch PROCTYPEAHEAD of (THIS.PROCESS])

(\GETSYSBUF
  [LAMBDA NIL                                            (* lmm " 9-JUL-83 00:56")
    (OR (AND \LONGSYSBUF (pop \LONGSYSBUF))
        (\GETREALSYSBUF])

(\PUTSYSBUF
  [LAMBDA (CHAR)                                         (* rmk%: "27-Nov-84 17:51")
    (PROG ((R (fetch (RING READ) of \SYSBUFFER))
           (W (fetch (RING WRITE) of \SYSBUFFER)))
          (RETURN (COND
                     ((EQ R W)                               (* Full)
                      NIL)
                     (T (\PUTBASEFAT \SYSBUFFER W CHAR)
                        (AND (EQ 0 R)
                             (replace (RING READ) of \SYSBUFFER with W))
                                                             (* Return random non-NIL value to 
                                                           indicate success for BKSYSBUF)
                        [replace (RING WRITE) of \SYSBUFFER with (COND
                                                                                ((EQ \SYSBUFFER.LAST 
                                                                                     W)
                                                                                 \SYSBUFFER.FIRST)
                                                                                (T (ADD1 W]
                        T])

(\PEEKSYSBUF
  [LAMBDA (STREAM)                                       (* bvm%: " 8-Feb-85 17:50")
    (PROG (R)
      WAIT
          (until (\SYSBUFP) do (BLOCK))
          (RETURN (if (TTY.PROCESSP)
                      then (if \LONGSYSBUF
                                   then (CAR \LONGSYSBUF)
                                 elseif (NEQ (SETQ R (fetch (RING READ) of \SYSBUFFER))
                                                 0)
                                   then                  (* Here's the vanilla case)
                                         (\GETBASEFAT \SYSBUFFER R)
                                 else 
          (* Foo an interrupt could have sneaked in here and gobbled down the remaining 
        characters)

                                       (GO WAIT))
                    elseif (THIS.PROCESS)
                      then (CAR (fetch PROCTYPEAHEAD of (THIS.PROCESS)))
                    else (SHOULDNT])
)

(RPAQ? \LONGSYSBUF )

(RPAQ? \\KEYBOARDWAITBOX.GLOBALRESOURCE )
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTDEF '\KEYBOARDWAITBOX 'RESOURCES '(NEW (CREATECELL \FIXP]
)
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ \SYSBUFSIZE 200)


(CONSTANTS (\SYSBUFSIZE 200))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \GETREALSYSBUF MACRO
          [NIL (PROG ((R (fetch (RING READ) of \SYSBUFFER)))
                     (RETURN (AND (NOT (EQ 0 R))
                                  (PROG1 (\GETBASEFAT \SYSBUFFER R)
                                      (AND [EQ (fetch (RING WRITE) of \SYSBUFFER)
                                               (replace (RING READ) of \SYSBUFFER
                                                  with (COND
                                                              ((EQ \SYSBUFFER.LAST R)
                                                               \SYSBUFFER.FIRST)
                                                              (T (ADD1 R]
                                           (replace (RING READ) of \SYSBUFFER with 0)))])
)
)
(DECLARE%: DOCOPY DONTEVAL@LOAD 



(* ; "Here because it must be done in init before PROC loaded")


(MOVD? 'NILL 'CARET)
)



(* ; "Key handler")

(DEFINEQ

(\KEYBOARDINIT
  [LAMBDA NIL                                            (* ; "Edited 19-Nov-87 16:46 by Snow")

    (DECLARE (GLOBALVARS \SAVEDSYSBUFFER))               (* ; 
                                                           "Sets up keyboard decoding tables.")

    (SETQ \CURRENTKEYACTION (SETQ \DEFAULTKEYACTION (KEYACTIONTABLE)))
                                                             (* ; 
                                                           "added \commandkeyaction 11-19-87 WAS")

    (SETQ \COMMANDKEYACTION (KEYACTIONTABLE))
    (SETQ \INTERRUPTSTATE (\ALLOCLOCKED 2))
    (PROGN (SETQ \SYSBUFFER (\ALLOCBLOCK (FOLDHI (ADD1 \SYSBUFFER.LAST)
                                                WORDSPERCELL)))
           (replace (RING READ) of \SYSBUFFER with 0)
           (replace (RING WRITE) of \SYSBUFFER with \SYSBUFFER.FIRST))
    (SETQ \SAVEDSYSBUFFER (ALLOCSTRING \SYSBUFSIZE NIL NIL T))
    (SETQ \LASTUSERACTION (LOCF (fetch LASTUSERACTION of \MISCSTATS)))
    (PROGN (SETQ \KEYBOARDEVENTQUEUE (\ALLOCLOCKED (FOLDHI (PLUS \KEYBOARDEVENT.LAST 
                                                                     \KEYBOARDEVENT.SIZE)
                                                              WORDSPERCELL)))
           (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0)
           (replace (RING WRITE) of \KEYBOARDEVENTQUEUE with \KEYBOARDEVENT.FIRST))
    (SETQ \LASTKEYSTATE (create KEYBOARDEVENT))
    (SETQ \SHIFTSTATE (create SHIFTSTATE))
    (SETQ \MOUSETIMERTEMP (SETUPTIMER 0 NIL 'TICKS))
    (MOUSECHORDWAIT \MOUSECHORDMILLISECONDS)
    (\KEYBOARDON])

(\KEYBOARDEVENTFN
  [LAMBDA (FDEV EVENT EXTRA)                             (* ; "Edited 11-Oct-90 09:49 by jds")
    (DECLARE (GLOBALVARS \KEYBOARD.BEFORETYPE \DORADOKEYACTIONS \DLIONKEYACTIONS 
                        \MAIKO.BEFOREKEYTYPE))
    (SELECTQ EVENT
        ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) 
             (SETQ \KEYBOARD.BEFORETYPE \MACHINETYPE)
             (SETQ \MAIKO.BEFOREKEYTYPE (LOGAND 7 (FETCH (IFPAGE DEVCONFIG) OF \InterfacePage
                                                         )))
             (SETQ \MAIKO.XBEFORE? (SELECTQ (MACHINETYPE)
                                       (MAIKO (EQUAL "X" (UNIX-GETPARM "DISPLAY")))
                                       NIL)))
        ((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM)  (* ; 
    "Restarting a world.  If we changed machines, fix up the key actions to match the new machine.")
                                                             (* ; "(COND ((NEQ \\MACHINETYPE \\KEYBOARD.BEFORETYPE) ; Changed machines.  Change Keyactions. (|for| X |in| (\\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS) |do| (KEYACTION (CAR X) (CDR X) \\COMMANDKEYACTION) (KEYACTION (CAR X) (CDR X) \\DEFAULTKEYACTION)) (MOUSECHORDWAIT (MOUSECHORDWAIT))))")
             [COND
                ((OR (NEQ \MACHINETYPE \KEYBOARD.BEFORETYPE)
                     (NEQ \MAIKO.XBEFORE? (SELECTQ (MACHINETYPE)
                                              (MAIKO (EQUAL "X" (UNIX-GETPARM "DISPLAY")))
                                              NIL)))         (* ; 
                                                           "Changed machines.  Change Keyactions.")
                 [COND
                    ((NEQ (MACHINETYPE)
                          'MAIKO)

                     (* ;; "Non-SUN, so just change machine-specific key actions:")

                     (for X in (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS)
                        do (KEYACTION (CAR X)
                                      (CDR X)
                                      \COMMANDKEYACTION)
                              (KEYACTION (CAR X)
                                     (CDR X)
                                     \DEFAULTKEYACTION)))
                    (T 
                       (* ;; 
                     "On a SUN:  Some keyactions contradict %"normal%" ones, so reset them all.")

                       (for X in (APPEND \ORIGKEYACTIONS (
                                                              \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS
                                                                  )) do (KEYACTION
                                                                             (CAR X)
                                                                             (CDR X)
                                                                             \COMMANDKEYACTION)
                                                                           (KEYACTION
                                                                            (CAR X)
                                                                            (CDR X)
                                                                            \DEFAULTKEYACTION]
                 (MOUSECHORDWAIT (MOUSECHORDWAIT)))
                ((EQ (MACHINETYPE)
                     'MAIKO)

                 (* ;; "Same machine type.  SO only worry if we're on SUNs, where the keyboard type can differ between machines.")

                 (COND
                    ((NEQ \MAIKO.BEFOREKEYTYPE (LOGAND 7 (fetch (IFPAGE DEVCONFIG) of 
                                                                                       \InterfacePage
                                                                )))
                     (for X in (APPEND \ORIGKEYACTIONS (
                                                              \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS
                                                                )) do (KEYACTION (CAR X)
                                                                                 (CDR X)
                                                                                 \COMMANDKEYACTION)
                                                                         (KEYACTION (CAR X)
                                                                                (CDR X)
                                                                                \DEFAULTKEYACTION))
                     (MOUSECHORDWAIT (MOUSECHORDWAIT])
        NIL])

(\ALLOCLOCKED
  [LAMBDA (NCELLS)                                       (* lmm "20-Apr-85 13:08")
                                                             (* allocate a block of NCELLS cells 
                                                           and lock it)
    (PROG [(BLOCK (\ALLOCBLOCK NCELLS NIL (IMIN NCELLS CELLSPERPAGE]
          (\LOCKCELL BLOCK (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BLOCK)
                                          (UNFOLD NCELLS WORDSPERCELL))
                                  WORDSPERPAGE))
          (RETURN BLOCK])

(\SETIOPOINTERS
  [LAMBDA NIL                                         (* ; "Edited 28-Apr-88 01:10 by MASINTER")
    (SELECTC (SETTOPVAL '\MACHINETYPE (fetch MachineType of \InterfacePage))
        ((LIST \DOLPHIN \DORADO) 
             (SETTOPVAL '\EM.MOUSEX (EMADDRESS MOUSEX.EM))
             (SETTOPVAL '\EM.MOUSEY (EMADDRESS MOUSEY.EM))
             (SETTOPVAL '\EM.CURSORX (EMADDRESS CURSORX.EM))
             (SETTOPVAL '\EM.CURSORY (EMADDRESS CURSORY.EM))
             (SETTOPVAL '\EM.REALUTILIN (EMADDRESS UTILIN.EM))
             (SETTOPVAL '\EM.KBDAD0 (EMADDRESS KBDAD0.EM))
             (SETTOPVAL '\EM.KBDAD1 (EMADDRESS KBDAD1.EM))
             (SETTOPVAL '\EM.KBDAD2 (EMADDRESS KBDAD2.EM))
             (SETTOPVAL '\EM.KBDAD3 (EMADDRESS KBDAD3.EM))
             (SETTOPVAL '\EM.KBDAD4 (LOCF (fetch FAKEKBDAD4 of \InterfacePage)))
             (\PUTBASE \EM.KBDAD4 0 ALLUP)
             (SETTOPVAL '\EM.KBDAD5 (LOCF (fetch FAKEKBDAD5 OF \InterfacePage)))
             (\PUTBASE \EM.KBDAD5 0 ALLUP)
             (SETTOPVAL '\EM.DISPINTERRUPT (EMADDRESS DISPINTERRUPT.EM))
             (SETTOPVAL '\EM.CURSORBITMAP (EMADDRESS CURSORBITMAP.EM))
             (SETTOPVAL '\EM.DISPLAYHEAD (EMADDRESS DCB.EM))
             (SETTOPVAL 'SCREENWIDTH (UNFOLD (fetch ScreenWidth of \InterfacePage)
                                            BITSPERWORD)))
        ((LIST \DANDELION \MAIKO) 
             (SETTOPVAL '\EM.MOUSEX (fetch DLMOUSEXPTR of \IOPAGE))
             (SETTOPVAL '\EM.MOUSEY (fetch DLMOUSEYPTR of \IOPAGE))
             (SETTOPVAL '\EM.CURSORX (fetch DLCURSORXPTR of \IOPAGE))
             (SETTOPVAL '\EM.CURSORY (fetch DLCURSORYPTR of \IOPAGE))
             (PROGN (SETTOPVAL '\EM.REALUTILIN (fetch DLUTILINPTR of \IOPAGE))

                    (* ;; "Where the hardware bits live, vs.  where the Lisp software sees them after reinterpretation by keyhandler")

                    )
             (SETTOPVAL '\EM.KBDAD0 (fetch DLKBDAD0PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD1 (fetch DLKBDAD1PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD2 (fetch DLKBDAD2PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD3 (fetch DLKBDAD3PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD4 (fetch DLKBDAD4PTR of \IOPAGE))
             (SETTOPVAL '\EM.KBDAD5 (fetch DLKBDAD5PTR of \IOPAGE))
             (SETTOPVAL '\EM.DISPINTERRUPT (fetch DLDISPINTERRUPTPTR of \IOPAGE))
             (SETTOPVAL '\EM.CURSORBITMAP (fetch DLCURSORBITMAPPTR of \IOPAGE))
             (SETTOPVAL '\EM.DISPLAYHEAD NIL)
             (SETTOPVAL 'SCREENWIDTH (SELECTC \MACHINETYPE
                                         (\MAIKO (SUBRCALL DSP-SCREENWIDTH))
                                         1024)))
        (\DAYBREAK (PROG ((KBDBASE (\DoveMisc.GetKBDBase)))
                         (SETTOPVAL '\EM.KBDAD0 (\ADDBASE KBDBASE 1))
                         (SETTOPVAL '\EM.KBDAD1 (\ADDBASE KBDBASE 2))
                         (SETTOPVAL '\EM.KBDAD2 (\ADDBASE KBDBASE 3))
                         (SETTOPVAL '\EM.KBDAD3 (\ADDBASE KBDBASE 4))
                         (SETTOPVAL '\EM.KBDAD4 (\ADDBASE KBDBASE 5))
                         (SETTOPVAL '\EM.KBDAD5 (\ADDBASE KBDBASE 6))
                         (SETTOPVAL '\EM.MOUSEX (\DoveMisc.GetMouseXBase))
                         (SETTOPVAL '\EM.MOUSEY (\DoveMisc.GetMouseYBase))
                         (SETTOPVAL '\EM.CURSORBITMAP (\DoveDisplay.GetCursorBitmapBase))
                                                             (* These three set this way to 
                                                           prevent address faults)
                         (SETTOPVAL '\EM.DISPINTERRUPT (fetch DLDISPINTERRUPTPTR of \IOPAGE))
                         (SETTOPVAL '\EM.CURSORX (fetch DLCURSORXPTR of \IOPAGE))
                         (SETTOPVAL '\EM.CURSORY (fetch DLCURSORYPTR of \IOPAGE))
                         (PROGN (SETTOPVAL '\EM.REALUTILIN KBDBASE)

         (* Where the hardware bits live, vs. where the Lisp software sees them after 
       reinterpretation by keyhandler)

                                )
                         (SETTOPVAL 'SCREENWIDTH (\DoveDisplay.ScreenWidth))))
        (RAID))
    (SETTOPVAL '\EM.UTILIN (LOCF (fetch (IFPAGE FAKEMOUSEBITS) of \InterfacePage])

(\KEYBOARDOFF
  [LAMBDA NIL                                         (* ; "Edited 20-Apr-88 10:28 by MASINTER")
    (\PUTBASE \EM.DISPINTERRUPT 0 (LOGAND (LOGXOR 65535 \LispKeyMask)
                                         (\GETBASE \EM.DISPINTERRUPT 0)))
    (COND
       ((EQ \MACHINETYPE \MAIKO)
        (SUBRCALL KEYBOARDSTATE NIL])

(\KEYBOARDON
  [LAMBDA (NOCHECK)                                   (* ; "Edited 24-Apr-88 00:03 by MASINTER")
    (\SETIOPOINTERS)
    (\PUTBASE \EM.DISPINTERRUPT 0 (LOGOR \LispKeyMask (\GETBASE \EM.DISPINTERRUPT 0)))
    (COND
       ((EQ \MACHINETYPE \MAIKO)
        (SUBRCALL KEYBOARDSTATE T])

(\KEYHANDLER
  [LAMBDA NIL                                            (* lmm "30-MAR-83 20:40")
    (\KEYHANDLER1])

(\KEYHANDLER1
  [LAMBDA NIL                                            (* ; "Edited 30-Mar-88 10:40 by Snow")

    (PROG ((OLD0 ALLUP)
           (OLD1 ALLUP)
           (OLD2 ALLUP)
           (OLD3 ALLUP)
           (OLD4 ALLUP)
           (OLD5 ALLUP)
           (OLDU ALLUP)
           (OLDFAKEU ALLUP)
           (LOOPCNT 10)
           (PERIODCNT 60)
           (MOUSESTATE \DLMOUSE.UP)
           (MOUSETIMER (LOCF (fetch DLMOUSETIMER of \MISCSTATS)))
           (MOUSETEMP (LOCF (fetch DLMOUSETEMP of \MISCSTATS)))
           CURSORX CURSORY YHOT)
          (SETQ \KEYBUFFERING NIL)
          (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0)
      LP  (\CONTEXTSWITCH \KbdFXP)
          [COND
             (\PERIODIC.INTERRUPT                            (* eventually can be replaced with 
                                                           general timer mechanism)
                    (COND
                       ((IGREATERP PERIODCNT 0)              (* Continue counting down to zero)
                        (SETQ PERIODCNT (SUB1 PERIODCNT)))
                       ((\CAUSEINTERRUPT \KbdFXP (FUNCTION \PERIODIC.INTERRUPTFRAME))
          (* When we've counted down, then keep trying to cause the interrupt, and 
        reset the counter when it finally happens)

                        (SETQ PERIODCNT (SUB1 (OR \PERIODIC.INTERRUPT.FREQUENCY 1]
          [COND
             ((OR (NEQ (\GETBASE \EM.MOUSEX 0)
                       CURSORX)
                  (NEQ (\GETBASE \EM.MOUSEY 0)
                       CURSORY))
              (\TRACKCURSOR (SETQ CURSORX (\GETBASE \EM.MOUSEX 0))
                     (SETQ CURSORY (\GETBASE \EM.MOUSEY 0]
          [COND
             ((OR [COND
                     ((OR (NEQ OLDU (\GETBASE \EM.REALUTILIN 0))
                          (COND
                             ((AND (EQ MOUSESTATE \DLMOUSE.WAITING)
                                   (IGREATERP (\BOXIDIFFERENCE (\RCLK MOUSETEMP)
                                                     MOUSETIMER)
                                          0))
          (* Timer expired on seeing both left and right down, so set state to normal)

                              (SETQ MOUSESTATE \DLMOUSE.NORMAL)
                              T)))
                      (SETQ MOUSESTATE (\DOMOUSECHORDING (SETQ OLDU (\GETBASE \EM.REALUTILIN 0))
                                              MOUSESTATE))
                      (NEQ OLDFAKEU (\GETBASE \EM.UTILIN 0]
                  (NEQ OLD0 (\GETBASE \EM.KBDAD0 0))
                  (NEQ OLD1 (\GETBASE \EM.KBDAD1 0))
                  (NEQ OLD2 (\GETBASE \EM.KBDAD2 0))
                  (NEQ OLD3 (\GETBASE \EM.KBDAD3 0))
                  (NEQ OLD4 (\GETBASE \EM.KBDAD4 0))
                  (NEQ OLD5 (\GETBASE \EM.KBDAD5 0)))
              (COND
                 ((EQ 0 (LOGAND (\GETBASE \EM.KBDAD2 0)
                               2114))                        (* Ctrl-shift-DEL panic interrupt --
                                                           switch to TeleRaid immediately)
                  (swap (fetch (IFPAGE TELERAIDFXP) of \InterfacePage)
                         (fetch (IFPAGE KbdFXP) of \InterfacePage))
                  (\KEYBOARDOFF)
                  (SETQ OLD2 (\GETBASE \EM.KBDAD2 0))
                  (GO LP)))
              [PROG ((W (fetch (RING WRITE) of \KEYBOARDEVENTQUEUE))
                     (R (fetch (RING READ) of \KEYBOARDEVENTQUEUE))
                     WPTR)
                    (COND
                       ((EQ R W)                             (* eventqueue full!)
                        (RETURN)))
                    (SETQ WPTR (\ADDBASE \KEYBOARDEVENTQUEUE W))
                    (\RCLK (LOCF (fetch TIME of WPTR)))
                    [with KEYBOARDEVENT WPTR (PROGN (SETQ W0 (SETQ OLD0 (\GETBASE \EM.KBDAD0 0)))
                                                        (SETQ W1 (SETQ OLD1 (\GETBASE \EM.KBDAD1 0)))
                                                        (SETQ W2 (SETQ OLD2 (\GETBASE \EM.KBDAD2 0)))
                                                        (SETQ W3 (SETQ OLD3 (\GETBASE \EM.KBDAD3 0)))
                                                        (SETQ W4 (SETQ OLD4 (\GETBASE \EM.KBDAD4 0)))
                                                        (SETQ W5 (SETQ OLD5 (\GETBASE \EM.KBDAD5 0)))
                                                        (SETQ WU (SETQ OLDFAKEU (\GETBASE \EM.UTILIN 
                                                                                       0]
                    (COND
                       ((EQ R 0)                             (* Queue was empty)
                        (replace (RING READ) of \KEYBOARDEVENTQUEUE with W)))
                    (replace (RING WRITE) of \KEYBOARDEVENTQUEUE
                       with (COND
                                   ((IGEQ W \KEYBOARDEVENT.LAST)
                                    \KEYBOARDEVENT.FIRST)
                                   (T (IPLUS W \KEYBOARDEVENT.SIZE]
              (OR \KEYBUFFERING (SETQ \KEYBUFFERING T]
          [COND
             [\KEYBUFFERING (COND
                               ((EQ \KEYBUFFERING T)
                                (COND
                                   ((\CAUSEINTERRUPT \KbdFXP (FUNCTION \DOBUFFEREDTRANSITIONS))
                                    (SETQ \KEYBUFFERING 'STARTED)
                                                             (* don't call until 
                                                           \DOBUFFEREDTRANSITIONS is done)
                                    ]
             (T (COND
                   (\PENDINGINTERRUPT (COND
                                         ((\CAUSEINTERRUPT \KbdFXP (FUNCTION \INTERRUPTFRAME))
                                          (SETQ \PENDINGINTERRUPT]
          [COND
             ((AND (NEQ \MACHINETYPE \MAIKO)
                   (ILEQ (SETQ LOOPCNT (SUB1 LOOPCNT))
                         0))                                 (* Only do this once in a while)
              (SETQ LOOPCNT (COND
                               ((\UPDATETIMERS)
          (* Timer was updated, so do it next time around, too, in case we just came 
        back from RAID or other bcpl code)

                                1)
                               (T 20]
          (COND
             ([AND NIL \TIMER.INTERRUPT.PENDING (IGREATERP (\BOXIDIFFERENCE
                                                            (\RCLK (LOCF (fetch DLMOUSETEMP
                                                                            of \MISCSTATS)))
                                                            (LOCF (fetch DLMOUSETIMER
                                                                     of \MISCSTATS)))
                                                       0)
                   (COND
                      ((EQ \TIMER.INTERRUPT.PENDING '\MOUSECHANGE)
                       (SETQ OLDU NIL)
                       T)
                      (T (\CAUSEINTERRUPT \KbdFXP (FUNCTION \TIMER.INTERRUPTFRAME]
              (SETQ \TIMER.INTERRUPT.PENDING)))
          (GO LP])

(\RESETKEYBOARD
  [LAMBDA NIL                                            (* ; "Edited 30-Mar-88 10:07 by Snow")

    (\SETIOPOINTERS)
          (* Called with lisp keyboard disabled whenever Lisp is resumed from bcpl 
        logout or copysys.)

    (SETQ \KEYBUFFERING NIL)
    (COND
       ((OR (EQ \MACHINETYPE \DANDELION)
            (EQ \MACHINETYPE \DAYBREAK)
            (EQ \MACHINETYPE \MAIKO))                        (* Initialize fake mouse bits to all 
                                                           up)
        (\PUTBASE \EM.UTILIN 0 ALLUP)))
    (with KEYBOARDEVENT \LASTKEYSTATE (SETQ W0 (\GETBASE \EM.KBDAD0 0))
           (SETQ W1 (\GETBASE \EM.KBDAD1 0))
           (SETQ W2 (\GETBASE \EM.KBDAD2 0))
           (SETQ W3 (\GETBASE \EM.KBDAD3 0))
           (SETQ W4 (\GETBASE \EM.KBDAD4 0))
           (SETQ W5 (\GETBASE \EM.KBDAD5 0))
           (SETQ WU (\GETBASE \EM.REALUTILIN 0))
           (SETQ LOCK (XKEYDOWNP 'LOCK))
           (SETQ 1SHIFT NIL)
           (SETQ 2SHIFT NIL)
           (SETQ CTRL NIL)
           (SETQ META NIL)
           (SETQ FONT NIL)
           (SETQ USERMODE1 NIL)
           (SETQ USERMODE2 NIL)
           (SETQ USERMODE3 NIL)
           (SETQ MOUSESTATE \DLMOUSE.UP))
    (SETQ \TIMER.INTERRUPT.PENDING)
    (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0)
    (replace (RING READ) of \SYSBUFFER with 0)
    (SETQ \LONGSYSBUF)
    (\DAYTIME0 \LASTUSERACTION)
    (\KEYBOARDON])

(\DOMOUSECHORDING
  [LAMBDA (REALUTILIN STATE)                             (* bvm%: " 9-Oct-85 11:24")
          (* Handles mouse transitions on a DLion.
        REALUTILIN is the actual util word from the processor.
        STATE is our internal state. Sets contents of \EM.UTILIN to reflect the 
        virtual mouse state, which may contain a middle mouse button even where there 
        is only a two-button mouse. Returns new state)

    (PROG (LRSTATE)
          [COND
             ((OR (NULL \MOUSECHORDTICKS)
                  (EQ (SETQ LRSTATE (LOGXOR (LOGAND REALUTILIN \MOUSE.ALLBITS)
                                           \MOUSE.ALLBITS))
                      0))
          (* Not interpreting chording, or both LEFT and RIGHT are up --
        real state and virtual state the same)

              (SETQ STATE \DLMOUSE.UP))
             (T 
          (* Either L or R or both are down, so have to decide about Middle)

                (SELECTC STATE
                    ((LIST \DLMOUSE.UP \DLMOUSE.WAITING) 
                         (SETQ REALUTILIN (LOGOR REALUTILIN \MOUSE.LRBIT))
                                                             (* Turn off the L and/or R bits)
                         (COND
                            ((EQ LRSTATE \MOUSE.LRBIT)
          (* Both L and R down at once, interpret as MIDDLE without waiting)

                             (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT)
                                                     REALUTILIN))
                             (SETQ STATE \DLMOUSE.MIDDLE))
                            ((NEQ STATE \DLMOUSE.WAITING)
          (* Only one of L and R down. Set timer, and ignore the down bit for now)

                             (\BOXIPLUS (\RCLK (LOCF (fetch DLMOUSETIMER of \MISCSTATS)))
                                    \MOUSECHORDTICKS)
                             (SETQ STATE \DLMOUSE.WAITING))))
                    (\DLMOUSE.MIDDLE 
          (* State is middle and at least one of L and R is still down, so consider it 
        to be still only middle)

                         (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT)
                                                 (LOGOR REALUTILIN \MOUSE.LRBIT)))
                         (SELECTC LRSTATE
                             (\MOUSE.LEFTBIT                 (* Right came up. Henceforth treat 
                                                           right transparently)
                                  (SETQ STATE \DLMOUSE.MIDDLE&RIGHT))
                             (\MOUSE.RIGHTBIT                (* Left came up. Henceforth treat 
                                                           left transparently)
                                  (SETQ STATE \DLMOUSE.MIDDLE&LEFT))
                             NIL))
                    (\DLMOUSE.MIDDLE&RIGHT                   (* Only ignore LEFT)
                         (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT)
                                                 (LOGOR REALUTILIN \MOUSE.LEFTBIT))))
                    (\DLMOUSE.MIDDLE&LEFT                    (* Only ignore RIGHT)
                         (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT)
                                                 (LOGOR REALUTILIN \MOUSE.RIGHTBIT))))
                    (PROGN 
          (* Remaining state is \DLMOUSE.NORMAL which means treat mouse normally, and 
        the only interesting transition is back to \DLMOUSE.UP)
]
          (\PUTBASE \EM.UTILIN 0 REALUTILIN)
          (RETURN STATE])

(\DOTRANSITIONS
  [LAMBDA (KEYBASE OLD NEW)                              (* ; "Edited  1-Feb-92 11:59 by jds")

    (* ;; "OLD and NEW are keyboard state words that are known to have changed.  KEYBASE is the number in hardware order of the key corresponding to the first bit in these words.  This function figures out the indices of transitioning keys and calls the decoder.")

    (for I (BITMASK _ (LLSH 1 15)) from 0 to 15
       do [OR (EQ 0 (LOGAND BITMASK (LOGXOR OLD NEW)))
                  (\DECODETRANSITION (IPLUS I KEYBASE)
                         (EQ 0 (LOGAND NEW BITMASK]
             (SETQ BITMASK (LRSH BITMASK 1)))
    T])

(\DECODETRANSITION
  [LAMBDA (KEYNUMBER DOWNFLG)                                (* ; "Edited 19-Nov-87 16:29 by Snow")

    (* ;; "KEYNUMBER is the key number in the hardware keyboard layout, DOWNFLG is T if the key just went down.  PENDINGINTERRUPT, bound in \KEYHANDLER, is set to the decoded character if it is an interrupt.")

    (.NOTELASTUSERACTION)
    (PROG ((TI (\TRANSINDEX KEYNUMBER DOWNFLG))
           (KEYSTATE \LASTKEYSTATE)
           ASCIICODE SHIFTED)
          (SELECTC (TRANSITIONFLAGS \CURRENTKEYACTION TI)
              (IGNORE.TF (RETURN))
              (LOCKSHIFT.TF                                  (* ; 
                                           "Take shift action if either Shift or Caps Lock is down")
                            (IF (fetch (KEYBOARDEVENT SHIFTORLOCK) of KEYSTATE)
                                THEN (SETQ SHIFTED T)))
              (NOLOCKSHIFT.TF                                (* ; 
                                                        "Take shift action only when Shift is down")
                   (IF (fetch (KEYBOARDEVENT SHIFT) of KEYSTATE)
                       THEN (SETQ SHIFTED T)))
              (EVENT.TF (RETURN))
              (1SHIFTUP.TF (replace (KEYBOARDEVENT 1SHIFT) of KEYSTATE with NIL)
                           (RETURN))
              (1SHIFTDOWN.TF (replace (KEYBOARDEVENT 1SHIFT) of KEYSTATE with T)
                             (RETURN))
              (2SHIFTUP.TF (replace (KEYBOARDEVENT 2SHIFT) of KEYSTATE with NIL)
                           (RETURN))
              (2SHIFTDOWN.TF (replace (KEYBOARDEVENT 2SHIFT) of KEYSTATE with T)
                             (RETURN))
              (LOCKUP.TF (replace (KEYBOARDEVENT LOCK) of KEYSTATE with NIL)
                         (RETURN))
              (LOCKDOWN.TF (replace (KEYBOARDEVENT LOCK) of KEYSTATE with T)
                           (RETURN))
              (LOCKTOGGLE.TF (replace (KEYBOARDEVENT LOCK) of KEYSTATE
                                with (NOT (fetch (KEYBOARDEVENT LOCK) of KEYSTATE)))
                             (RETURN))
              (CTRLUP.TF (replace (KEYBOARDEVENT CTRL) of KEYSTATE with NIL)
                         (RETURN))
              (CTRLDOWN.TF (replace (KEYBOARDEVENT CTRL) of KEYSTATE with T)
                           (RETURN))
              (METAUP.TF (replace (KEYBOARDEVENT META) of KEYSTATE with NIL)
                         (RETURN))
              (METADOWN.TF (replace (KEYBOARDEVENT META) of KEYSTATE with T)
                           (RETURN))
              (FONTUP.TF (replace (KEYBOARDEVENT FONT) of KEYSTATE with NIL)
                         (RETURN))
              (FONTDOWN.TF (replace (KEYBOARDEVENT FONT) of KEYSTATE with T)
                           (RETURN))
              (FONTTOGGLE.TF (replace (KEYBOARDEVENT FONT) of KEYSTATE
                                with (NOT (fetch (KEYBOARDEVENT FONT) of KEYSTATE)))
                             (RETURN))
              (USERMODE1UP.TF 
                   (replace (KEYBOARDEVENT USERMODE1) of KEYSTATE with NIL)
                   (RETURN))
              (USERMODE1DOWN.TF 
                   (replace (KEYBOARDEVENT USERMODE1) of KEYSTATE with T)
                   (RETURN))
              (USERMODE1TOGGLE.TF 
                   (replace (KEYBOARDEVENT USERMODE1) of KEYSTATE
                      with (NOT (fetch (KEYBOARDEVENT USERMODE1) of KEYSTATE)))
                   (RETURN))
              (USERMODE2UP.TF 
                   (replace (KEYBOARDEVENT USERMODE2) of KEYSTATE with NIL)
                   (RETURN))
              (USERMODE2DOWN.TF 
                   (replace (KEYBOARDEVENT USERMODE2) of KEYSTATE with T)
                   (RETURN))
              (USERMODE2TOGGLE.TF 
                   (replace (KEYBOARDEVENT USERMODE2) of KEYSTATE
                      with (NOT (fetch (KEYBOARDEVENT USERMODE2) of KEYSTATE)))
                   (RETURN))
              (USERMODE3UP.TF 
                   (replace (KEYBOARDEVENT USERMODE3) of KEYSTATE with NIL)
                   (RETURN))
              (USERMODE3DOWN.TF 
                   (replace (KEYBOARDEVENT USERMODE3) of KEYSTATE with T)
                   (RETURN))
              (USERMODE3TOGGLE.TF 
                   (replace (KEYBOARDEVENT USERMODE3) of KEYSTATE
                      with (NOT (fetch (KEYBOARDEVENT USERMODE3) of KEYSTATE)))
                   (RETURN))
              (SHOULDNT))

     (* ;; 
   "Only the LOCKSHIFT and NOLOCKSHIFT cases make it to here, having set SHIFTED if appropriate.")

          [SETQ ASCIICODE (COND
                             (SHIFTED (TRANSITIONSHIFTCODE \CURRENTKEYACTION TI))
                             (T (TRANSITIONCODE \CURRENTKEYACTION TI]
          [COND
             ((OR (fetch (KEYBOARDEVENT CTRL) of KEYSTATE)
                  (fetch (KEYBOARDEVENT META) of KEYSTATE)
                  (fetch (KEYBOARDEVENT FONT) of KEYSTATE))
              [IF (IGREATERP ASCIICODE 127)
                  THEN 

                        (* ;; "Non-ascii interpretation--what is cntrl/meta supposed to mean?  Try using the original interpretation.  This way we can type ^E or Meta-D even if Russian keyboard is set, but doesn't mess up simple ascii remappings, such as bs->del.")

                        (SETQ ASCIICODE (COND
                                           (SHIFTED (TRANSITIONSHIFTCODE \COMMANDKEYACTION TI))
                                           (T (TRANSITIONCODE \COMMANDKEYACTION TI]
              [COND
                 ((fetch (KEYBOARDEVENT CTRL) of KEYSTATE)
                  (SETQ ASCIICODE (LOGAND ASCIICODE \CTRLMASK]
              (COND
                 ((AND (OR (fetch (KEYBOARDEVENT META) of KEYSTATE)
                           (fetch (KEYBOARDEVENT FONT) of KEYSTATE))
                       (ILESSP ASCIICODE \KEYBOARD.META))
                  (SETQ ASCIICODE (LOGOR ASCIICODE \KEYBOARD.META]
          (COND
             ((ASSOC ASCIICODE (fetch INTERRUPTLIST of \CURRENTKEYACTION))
              (SETQ PENDINGINTERRUPT T)
              (replace WAITINGINTERRUPT of \INTERRUPTSTATE with T)
              (replace INTCHARCODE of \INTERRUPTSTATE with ASCIICODE))
             (T (\PUTSYSBUF ASCIICODE])

(MOUSECHORDWAIT
  [LAMBDA MSECS                                          (* MPL "21-Jun-85 16:31")
    (DECLARE (GLOBALVARS \RCLKMILLISECOND))
    (PROG1 (AND \MOUSECHORDTICKS \MOUSECHORDMILLISECONDS)
           (COND
              ((IGREATERP MSECS 0)
               (SETQ \MOUSECHORDTICKS (AND (ARG MSECS 1)
                                           (IMIN MAX.SMALLP (ITIMES (SETQ \MOUSECHORDMILLISECONDS
                                                                     (OR (SMALLP (ARG MSECS 1))
                                                                         50))
                                                                   \RCLKMILLISECOND])

(\TRACKCURSOR
  [LAMBDA (CURSORX CURSORY)                              (* ; "Edited 30-Mar-88 11:11 by Snow")

    (DECLARE (GLOBALVARS \CURSORDESTHEIGHT \CURSORDESTWIDTH))
    (.NOTELASTUSERACTION)
    [COND
       ((OR [COND
               ((IGEQ CURSORX (IDIFFERENCE \CURSORDESTWIDTH \CURSORHOTSPOTX))
          (* Large cursor values are either out of bounds to the right or are negative 
        values (16-bit bcpl signed numbers))

                (COND
                   [(IGREATERP CURSORX 32767)                (* Cursor value is negative)
                    (COND
                       ((ILESSP (IPLUS (SUB1 (IDIFFERENCE CURSORX 65535))
                                       \CURSORHOTSPOTX)
                               0)
          (* Cursor pos + hotspot is still off to the left
        (the IPLUS is an optimization of (\XMOUSECOORD))%, so clip to effective zero)

                        (SETQ CURSORX (COND
                                         ((EQ \MACHINETYPE \DANDELION)
                                                             (* Temporary workaround)
                                          0)
                                         (T (UNSIGNED (IMINUS \CURSORHOTSPOTX)
                                                   BITSPERWORD]
                   (T (SETQ CURSORX (SUB1 (IDIFFERENCE \CURSORDESTWIDTH \CURSORHOTSPOTX]
            (IGEQ CURSORY (IDIFFERENCE \CURSORDESTHEIGHT HARDCURSORHEIGHT)))
          (* repeat test so that both X and Y will get clipped each cycle.
        This keeps the cursor from moving off the screen.)

        [COND
           ((IGEQ CURSORY (IDIFFERENCE \CURSORDESTHEIGHT \CURSORHOTSPOTY))
          (* Large cursor values are either out of bounds to the bottom or are negative 
        values (16-bit bcpl signed numbers))

            (COND
               [(IGREATERP CURSORY 32767)                    (* Cursor value is negative)
                (COND
                   ((ILESSP (IPLUS (SUB1 (IDIFFERENCE CURSORY 65535))
                                   \CURSORHOTSPOTY)
                           0)
          (* Cursor pos + hotspot is still off to the top, so clip to effective zero)

                    (SETQ CURSORY (COND
                                     ((OR (EQ \MACHINETYPE \DANDELION)
                                          (EQ \MACHINETYPE \DAYBREAK))
                                                             (* Temporary workaround)
                                      0)
                                     (T (UNSIGNED (IMINUS \CURSORHOTSPOTY)
                                               BITSPERWORD]
               (T (SETQ CURSORY (SUB1 (IDIFFERENCE \CURSORDESTHEIGHT \CURSORHOTSPOTY]
          (* If need to clip mouse, do so here. \SETMOUSEXY MACRO takes dlion 
        complexities into account.)

        (COND
           ((NEQ \MACHINETYPE \MAIKO)
            (\SETMOUSEXY CURSORX CURSORY]
    (COND
       (\SOFTCURSORUPP (\SOFTCURSORPOSITION CURSORX CURSORY)))
    (COND
       ((EQ \MACHINETYPE \DAYBREAK)
          (* Have to kick DAYBREAK IOP to track the cursor.
        *)

        (\DoveDisplay.SetCursorPosition CURSORX CURSORY)))
    (\PUTBASE \EM.CURSORX 0 CURSORX)
    (\PUTBASE \EM.CURSORY 0 CURSORY])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \SUN.TYPE3KEYBOARD 0)

(RPAQQ \SUN.TYPE4KEYBOARD 1)

(RPAQQ \SUN.JLEKEYBOARD 2)

(RPAQQ \TOSHIBA.JIS 7)


(CONSTANTS (\SUN.TYPE3KEYBOARD 0)
       (\SUN.TYPE4KEYBOARD 1)
       (\SUN.JLEKEYBOARD 2)
       (\TOSHIBA.JIS 7))
)

(RPAQ? \MOUSECHORDTICKS )

(RPAQ? \MOUSECHORDMILLISECONDS 50)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\KEYBOARDINIT)
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS .NOTELASTUSERACTION MACRO (NIL (\BLT \LASTUSERACTION (LOCF (fetch SECONDSTMP
                                                                                of \MISCSTATS))
                                                       WORDSPERCELL)))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ ALLUP 65535)

(RPAQQ \CTRLMASK 159)

(RPAQQ \METABIT 128)


(CONSTANTS ALLUP \CTRLMASK \METABIT)
)


(RPAQQ DLMOUSEBITS ((\MOUSE.LEFTBIT 4)
                        (\MOUSE.RIGHTBIT 2)
                        (\MOUSE.MIDDLEBIT 1)
                        (\MOUSE.ALLBITS 7)
                        (\MOUSE.LRBIT 6)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \MOUSE.LEFTBIT 4)

(RPAQQ \MOUSE.RIGHTBIT 2)

(RPAQQ \MOUSE.MIDDLEBIT 1)

(RPAQQ \MOUSE.ALLBITS 7)

(RPAQQ \MOUSE.LRBIT 6)


(CONSTANTS (\MOUSE.LEFTBIT 4)
       (\MOUSE.RIGHTBIT 2)
       (\MOUSE.MIDDLEBIT 1)
       (\MOUSE.ALLBITS 7)
       (\MOUSE.LRBIT 6))
)


(RPAQQ DLMOUSESTATES ((\DLMOUSE.UP 0)
                          (\DLMOUSE.WAITING 1)
                          (\DLMOUSE.NORMAL 2)
                          (\DLMOUSE.MIDDLE 3)
                          (\DLMOUSE.MIDDLE&LEFT 4)
                          (\DLMOUSE.MIDDLE&RIGHT 5)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \DLMOUSE.UP 0)

(RPAQQ \DLMOUSE.WAITING 1)

(RPAQQ \DLMOUSE.NORMAL 2)

(RPAQQ \DLMOUSE.MIDDLE 3)

(RPAQQ \DLMOUSE.MIDDLE&LEFT 4)

(RPAQQ \DLMOUSE.MIDDLE&RIGHT 5)


(CONSTANTS (\DLMOUSE.UP 0)
       (\DLMOUSE.WAITING 1)
       (\DLMOUSE.NORMAL 2)
       (\DLMOUSE.MIDDLE 3)
       (\DLMOUSE.MIDDLE&LEFT 4)
       (\DLMOUSE.MIDDLE&RIGHT 5))
)


(RPAQQ TRANSITIONFLAGS
       (ALTGRDOWN.TF ALTGRUP.TF ALTGRTOGGLE.TF CTRLDOWN.TF CTRLUP.TF DEADKEY.TF IGNORE.TF EVENT.TF 
              LOCKDOWN.TF LOCKSHIFT.TF LOCKTOGGLE.TF LOCKUP.TF NOLOCKSHIFT.TF 1SHIFTDOWN.TF 
              1SHIFTUP.TF 2SHIFTDOWN.TF 2SHIFTUP.TF METADOWN.TF METAUP.TF FONTDOWN.TF FONTUP.TF 
              FONTTOGGLE.TF USERMODE1UP.TF USERMODE1DOWN.TF USERMODE1TOGGLE.TF USERMODE2UP.TF 
              USERMODE2DOWN.TF USERMODE2TOGGLE.TF USERMODE3UP.TF USERMODE3DOWN.TF USERMODE3TOGGLE.TF))
(DECLARE%: EVAL@COMPILE 

(RPAQQ ALTGRDOWN.TF 27)

(RPAQQ ALTGRUP.TF 28)

(RPAQQ ALTGRTOGGLE.TF 29)

(RPAQQ CTRLDOWN.TF 5)

(RPAQQ CTRLUP.TF 4)

(RPAQQ DEADKEY.TF 30)

(RPAQQ IGNORE.TF 0)

(RPAQQ EVENT.TF 1)

(RPAQQ LOCKDOWN.TF 8)

(RPAQQ LOCKSHIFT.TF 2)

(RPAQQ LOCKTOGGLE.TF 14)

(RPAQQ LOCKUP.TF 7)

(RPAQQ NOLOCKSHIFT.TF 3)

(RPAQQ 1SHIFTDOWN.TF 6)

(RPAQQ 1SHIFTUP.TF 9)

(RPAQQ 2SHIFTDOWN.TF 11)

(RPAQQ 2SHIFTUP.TF 10)

(RPAQQ METADOWN.TF 13)

(RPAQQ METAUP.TF 12)

(RPAQQ FONTDOWN.TF 24)

(RPAQQ FONTUP.TF 25)

(RPAQQ FONTTOGGLE.TF 26)

(RPAQQ USERMODE1UP.TF 15)

(RPAQQ USERMODE1DOWN.TF 16)

(RPAQQ USERMODE1TOGGLE.TF 17)

(RPAQQ USERMODE2UP.TF 18)

(RPAQQ USERMODE2DOWN.TF 19)

(RPAQQ USERMODE2TOGGLE.TF 20)

(RPAQQ USERMODE3UP.TF 21)

(RPAQQ USERMODE3DOWN.TF 22)

(RPAQQ USERMODE3TOGGLE.TF 23)


(CONSTANTS ALTGRDOWN.TF ALTGRUP.TF ALTGRTOGGLE.TF CTRLDOWN.TF CTRLUP.TF DEADKEY.TF IGNORE.TF EVENT.TF
       LOCKDOWN.TF LOCKSHIFT.TF LOCKTOGGLE.TF LOCKUP.TF NOLOCKSHIFT.TF 1SHIFTDOWN.TF 1SHIFTUP.TF 
       2SHIFTDOWN.TF 2SHIFTUP.TF METADOWN.TF METAUP.TF FONTDOWN.TF FONTUP.TF FONTTOGGLE.TF 
       USERMODE1UP.TF USERMODE1DOWN.TF USERMODE1TOGGLE.TF USERMODE2UP.TF USERMODE2DOWN.TF 
       USERMODE2TOGGLE.TF USERMODE3UP.TF USERMODE3DOWN.TF USERMODE3TOGGLE.TF)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \TRANSINDEX MACRO ((KEYNUMBER DOWNFLG)
                                     (COND
                                        (DOWNFLG (IPLUS \NKEYS KEYNUMBER))
                                        (T KEYNUMBER))))

(PUTPROPS ARMEDCODE MACRO ((TABLE CHAR)
                                   (\GETBASEBIT (fetch (KEYACTION ARMED)
                                                       TABLE)
                                          CHAR)))

(PUTPROPS TRANSITIONALTGRCODE MACRO ((TABLE CHAR)
                                             (\GETBASE (fetch (KEYACTION ALTGRAPHCODES)
                                                          of TABLE)
                                                    CHAR)))

(PUTPROPS TRANSITIONSHIFTCODE MACRO ((TABLE CHAR)
                                             (\GETBASE (fetch (KEYACTION SHIFTCODES)
                                                              TABLE)
                                                    CHAR)))

(PUTPROPS TRANSITIONCODE MACRO ((TABLE CHAR)
                                        (\GETBASE (fetch (KEYACTION CODES)
                                                         TABLE)
                                               CHAR)))

(PUTPROPS TRANSITIONFLAGS MACRO ((TABLE CHAR)
                                         (\GETBASEBYTE (fetch (KEYACTION FLAGS)
                                                              TABLE)
                                                CHAR)))

(PUTPROPS TRANSITIONDEADLIST MACRO ((TABLE CHAR SHIFTED)
                                            (\GETBASEPTR (fetch (KEYACTION DEADKEYLIST)
                                                            of TABLE)
                                                   (LLSH (COND
                                                            (SHIFTED (IPLUS CHAR \NKEYS \NKEYS))
                                                            (T CHAR))
                                                         1))))

(PUTPROPS CHECKFORDEADKEY MACRO
          [(KEYCODE TABLE CHAR SHIFTED)
           (LET ((CODE KEYCODE))
                (COND
                   [(IEQP CODE 65535)
                    `(DEADKEY ,(\GETBASEPTR (fetch (KEYACTION DEADKEYLIST) of TABLE)
                                      (LLSH (COND
                                               (SHIFTED (IPLUS CHAR \NKEYS \NKEYS))
                                               (T CHAR))
                                            1]
                   (T CODE])
)

(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE

(BLOCKRECORD KEYACTION (
                            (* ;; "KEYACTION Table:  For interpreting keystrokes.  Stored as a 8-cell block of untyped pointer hunk storage.")

                            FLAGS                            (* ; "Flag byte per key# (one for down-transtion, 1 for up-.) to describe whether lockshifting occrrs, you ignore the transition, etc.")
                            CODES                            (* ; 
                     "Table of character codes generated by each key when no shift key is pressed.")
                            SHIFTCODES                       (* ; 
                    "Table of character codes generated by each key when the shift key is pressed.")
                            ARMED                            (* ; "Not sure...")
                            INTERRUPTLIST                    (* ; "List of armed interrupts?")
                            ALTGRAPHCODES                    (* ; 
                                "Table of codes to be generated when the ALT-GRAPH key is pressed.")
                            DEADKEYLIST                      (* ; "Block of dead-key handlers, with the nominal up-transition fields filled by the shifted-case tables.  Each %"table%" is an ALIST of orignal code => accented code.  no entry means punt the accent..")
                            )
                           FLAGS _ (\ALLOCBLOCK (FOLDHI (IPLUS \NKEYS \NKEYS)
                                                       BYTESPERCELL))
                           CODES _ (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS)
                                                       WORDSPERCELL))
                           SHIFTCODES _ (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS)
                                                            WORDSPERCELL))
                           ARMED _ (\ALLOCBLOCK (FOLDHI (ADD1 \MAXTHINCHAR)
                                                       BITSPERCELL))
                           ALTGRAPHCODES _ (\ALLOCBLOCK (FOLDHI (PLUS \NKEYS \NKEYS)
                                                               WORDSPERCELL))
                           DEADKEYLIST _ (\ALLOCBLOCK (PLUS \NKEYS \NKEYS \NKEYS \NKEYS)
                                                T)
                           (CREATE (\ALLOCBLOCK 7 PTRBLOCK.GCT))
                           [TYPE? (AND (\BLOCKDATAP DATUM)
                                           (IGEQ (\#BLOCKDATACELLS DATUM)
                                                 5)
                                           (OR (NULL (FETCH (KEYACTION INTERRUPTLIST)
                                                        OF DATUM))
                                               (LISTP (FETCH INTERRUPTLIST OF DATUM)))
                                           (\BLOCKDATAP (FETCH (KEYACTION FLAGS)
                                                               DATUM))
                                           (\BLOCKDATAP (FETCH (KEYACTION CODES)
                                                               DATUM))
                                           (\BLOCKDATAP (FETCH (KEYACTION ARMED)
                                                               DATUM])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \NKEYS 112)


(CONSTANTS \NKEYS)
)

(* "END EXPORTED DEFINITIONS")


(DECLARE%: EVAL@COMPILE

(BLOCKRECORD RING ((READ WORD)
                       (WRITE WORD)))
)




(* ; "can get rid of shiftstate after clients have been fixed")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS SHIFTSTATE [[DUMMYSHIFT (NOT (EQ 0 (LOGAND (\GETBASEBYTE DATUM 0)
                                                         (LOGOR 1 2]
                           [DUMMY1SHIFT [NOT (EQ 0 (LOGAND 1 (\GETBASEBYTE DATUM 0]
                                  (\PUTBASEBYTE DATUM 0 (COND
                                                           (NEWVALUE (LOGOR 1 (\GETBASEBYTE DATUM 0))
                                                                  )
                                                           (T (LOGAND (\GETBASEBYTE DATUM 0)
                                                                     (LOGXOR \CHARMASK 1]
                           [DUMMY2SHIFT [NOT (EQ 0 (LOGAND 2 (\GETBASEBYTE DATUM 0]
                                  (\PUTBASEBYTE DATUM 0 (COND
                                                           (NEWVALUE (LOGOR 2 (\GETBASEBYTE DATUM 0))
                                                                  )
                                                           (T (LOGAND (\GETBASEBYTE DATUM 0)
                                                                     (LOGXOR \CHARMASK 2]
                           [DUMMYLOCK [NOT (EQ 0 (LOGAND 4 (\GETBASEBYTE DATUM 0]
                                  (\PUTBASEBYTE DATUM 0 (COND
                                                           (NEWVALUE (LOGOR 4 (\GETBASEBYTE DATUM 0))
                                                                  )
                                                           (T (LOGAND (\GETBASEBYTE DATUM 0)
                                                                     (LOGXOR \CHARMASK 4]
                           [DUMMYSHIFTORLOCK (NOT (EQ 0 (\GETBASEBYTE DATUM 0)))
                                  (\PUTBASEBYTE DATUM 0 (COND
                                                           (NEWVALUE (HELP 
                                                                         " Can't turn on SHIFTORLOCK"
                                                                           ))
                                                           (T 0]
                           [DUMMYCTRL (NOT (EQ 0 (\GETBASEBYTE DATUM 1)))
                                  (\PUTBASEBYTE DATUM 1 (COND
                                                           (NEWVALUE 1)
                                                           (T 0]
                           [DUMMYMETA (NOT (EQ 0 (\GETBASEBYTE DATUM 2)))
                                  (\PUTBASEBYTE DATUM 2 (COND
                                                           (NEWVALUE 1)
                                                           (T 0]
                           [DUMMYFONT (NEQ 0 (LOGAND (LLSH 1 3)
                                                    (\GETBASEBYTE DATUM 3)))
                                  (\PUTBASEBYTE DATUM 3 (COND
                                                           (NEWVALUE (LOGOR (LLSH 1 3)
                                                                            (\GETBASEBYTE DATUM 3)))
                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
                                                                     (LOGXOR \CHARMASK
                                                                            (LLSH 1 3]
                           [DUMMYUSERMODE1 (NEQ 0 (LOGAND (LLSH 1 0)
                                                         (\GETBASEBYTE DATUM 3)))
                                  (\PUTBASEBYTE DATUM 3 (COND
                                                           (NEWVALUE (LOGOR (LLSH 1 0)
                                                                            (\GETBASEBYTE DATUM 3)))
                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
                                                                     (LOGXOR \CHARMASK
                                                                            (LLSH 1 0]
                           [DUMMYUSERMODE2 (NEQ 0 (LOGAND (LLSH 1 1)
                                                         (\GETBASEBYTE DATUM 3)))
                                  (\PUTBASEBYTE DATUM 3 (COND
                                                           (NEWVALUE (LOGOR (LLSH 1 1)
                                                                            (\GETBASEBYTE DATUM 3)))
                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
                                                                     (LOGXOR \CHARMASK
                                                                            (LLSH 1 1]
                           [DUMMYUSERMODE3 (NEQ 0 (LOGAND (LLSH 1 2)
                                                         (\GETBASEBYTE DATUM 3)))
                                  (\PUTBASEBYTE DATUM 3 (COND
                                                           (NEWVALUE (LOGOR (LLSH 1 2)
                                                                            (\GETBASEBYTE DATUM 3)))
                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
                                                                     (LOGXOR \CHARMASK
                                                                            (LLSH 1 2]
                           [DUMMYALTGRAPH (NEQ 0 (LOGAND (LLSH 1 4)
                                                        (\GETBASEBYTE DATUM 3)))
                                  (\PUTBASEBYTE DATUM 3 (COND
                                                           (NEWVALUE (LOGOR (LLSH 1 4)
                                                                            (\GETBASEBYTE DATUM 3)))
                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
                                                                     (LOGXOR \CHARMASK
                                                                            (LLSH 1 4]
                           (DUMMYDEADKEYPENDING (NEQ 0 (LOGAND (LLSH 1 5)
                                                              (\GETBASEBYTE DATUM 3)))
                                  (\PUTBASEBYTE DATUM 3 (COND
                                                           (NEWVALUE (LOGOR (LLSH 1 5)
                                                                            (\GETBASEBYTE DATUM 3)))
                                                           (T (LOGAND (\GETBASEBYTE DATUM 3)
                                                                     (LOGXOR \CHARMASK
                                                                            (LLSH 1 5]
                          (CREATE (\ALLOCBLOCK (FOLDHI 3 BYTESPERCELL))))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \SHIFTSTATE \MOUSETIMERTEMP)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ NRINGINDEXWORDS 2)


(CONSTANTS NRINGINDEXWORDS)
)

(DECLARE%: EVAL@COMPILE 

(RPAQ \SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))

(RPAQ \SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE)))


[CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD))
       (\SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE]
)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \KEYNAMES
       ((5 %% FIVE)
        (4 $ FOUR)
        (6 ~ SIX)
        (e E)
        (7 & SEVEN)
        (d D)
        (u U)
        (v V)
        (0 %) ZERO)
        (k K)
        (- %)
        (p P)
        (/ ?)
        (\ %| FONT LOOKS)
        (LF SAME)
        (BS <-)
        (3 %# THREE)
        (2 @ TWO)
        (w W)
        (q Q)
        (s S)
        (a A)
        (9 %( NINE)
        (i I)
        (x X)
        (o O)
        (l L)
        (%, <)
        (%' %")
        (%] })
        (BLANK-MIDDLE OPEN DBK-HELP)
        (BLANK-TOP KEYBOARD DBK-META)
        (1 ! ONE)
        (ESC ESCAPE ->)
        (TAB =>)
        (f F)
        (CTRL PROP'S EDIT)
        (c C)
        (j J)
        (b B)
        (z Z)
        (LSHIFT)
        (%. >)
        (; %:)
        (CR <-%|)
        (_ ^)
        (DEL DELETE)
        (SKIP NEXT)
        (r R)
        (t T)
        (g G)
        (y Y)
        (h H)
        (8 * EIGHT)
        (n N)
        (m M)
        (LOCK)
        (SPACE)
        (%[ {)
        (= +)
        (RSHIFT)
        (BLANK-BOTTOM STOP)
        (MOVE)
        (UNDO)
        (UTIL0 SUN-KEYPAD=)
        (UTIL1 SUN-KEYPAD/)
        (UTIL2 SUPER/SUB)
        (UTIL3 CASE)
        (UTIL4 STRIKEOUT)
        (UTIL5 KEYPAD2)
        (UTIL6 KEYPAD3 PGDN)
        (UTIL7 SUN-LF)
        (PAD1 LEFTKEY CAPSLOCK KEYPAD+)
        (PAD2 LEFTMIDDLEKEY NUMLOCK KEYPAD-)
        (PAD3 MIDDLEKEY SCROLLLOCK KEYPAD*)
        (PAD4 RIGHTMIDDLEKEY BREAK KEYPAD/ SUN-PAUSE)
        (PAD5 RIGHTKEY DOIT PRTSC)
        (LEFT RED MOUSERED)
        (RIGHT BLUE MOUSEBLUE)
        (MIDDLE YELLOW MOUSEYELLOW)
        (MARGINS)
        (K41 KEYPAD7 HOME)
        (K42 KEYPAD8)
        (K43 KEYPAD9 PGUP)
        (K44 KEYPAD4)
        (K45 KEYPAD5)
        (K46 SUN-LEFT-SPACE)
        (K47 KEYPAD6)
        (K48 RIGHT-COMMAND SUN-RIGHT-SPACE)
        (COPY)
        (FIND)
        (AGAIN)
        (HELP)
        (DEF'N EXPAND)
        (K4E KEYPAD1 END)
        (ALWAYS-ON-1)
        (ALWAYS-ON-2)
        (CENTER)
        (K52 KEYPAD0 INS)
        (BOLD)
        (ITALICS)
        (UNDERLINE)
        (SUPERSCRIPT)
        (SUBSCRIPT)
        (LARGER SMALLER)
        (K59 KEYPAD%| KEYPAD.)
        (K5A KEYPAD\ KEYPAD, SUN-F10)
        (K5B SUN-F11)
        (K5C SUN-F12)
        (DEFAULTS SUN-PROP)
        (K5E SUN-PRTSC)
        (K5F SUN-OPEN)))
)



(* ;; 
"\maikokeyactions does not contain keyactions of the form %"2,50%" because it breaks the loadup process on the sun."
)


(RPAQQ \ORIGKEYACTIONS
       ((0 (53 "%%" NOLOCKSHIFT))
        (1 (52 "$" NOLOCKSHIFT))
        (2 (54 "~" NOLOCKSHIFT))
        (3 ("e" "E" LOCKSHIFT))
        (4 (55 "&" NOLOCKSHIFT))
        (5 ("d" "D" LOCKSHIFT))
        (6 ("u" "U" LOCKSHIFT))
        (7 ("v" "V" LOCKSHIFT))
        (8 (48 ")" NOLOCKSHIFT))
        (9 ("k" "K" LOCKSHIFT))
        (10 ("-" "-" NOLOCKSHIFT))
        (11 ("p" "P" LOCKSHIFT))
        (12 ("/" "?" NOLOCKSHIFT))
        (13 ("\" "|" NOLOCKSHIFT))
        (14 (10 96 NOLOCKSHIFT))
        (15 (8 8 NOLOCKSHIFT))
        (16 (51 "#" NOLOCKSHIFT))
        (17 (50 "@" NOLOCKSHIFT))
        (18 ("w" "W" LOCKSHIFT))
        (19 ("q" "Q" LOCKSHIFT))
        (20 ("s" "S" LOCKSHIFT))
        (21 ("a" "A" LOCKSHIFT))
        (22 (57 "(" NOLOCKSHIFT))
        (23 ("i" "I" LOCKSHIFT))
        (24 ("x" "X" LOCKSHIFT))
        (25 ("o" "O" LOCKSHIFT))
        (26 ("l" "L" LOCKSHIFT))
        (27 ("," "<" NOLOCKSHIFT))
        (28 ("'" "%"" NOLOCKSHIFT))
        (29 ("]" "}" NOLOCKSHIFT))
        (30 (194 194 NOLOCKSHIFT))
        (31 (193 193 NOLOCKSHIFT))
        (32 (49 "!" NOLOCKSHIFT))
        (33 (27 27 NOLOCKSHIFT))
        (34 (9 9 NOLOCKSHIFT))
        (35 ("f" "F" LOCKSHIFT))
        (36 CTRLDOWN . CTRLUP)
        (37 ("c" "C" LOCKSHIFT))
        (38 ("j" "J" LOCKSHIFT))
        (39 ("b" "B" LOCKSHIFT))
        (40 ("z" "Z" LOCKSHIFT))
        (41 1SHIFTDOWN . 1SHIFTUP)
        (42 ("." ">" NOLOCKSHIFT))
        (43 (";" ":" NOLOCKSHIFT))
        (44 (13 13 NOLOCKSHIFT))
        (45 ("_" "^" NOLOCKSHIFT))
        (46 (127 535 NOLOCKSHIFT))
        (47 ("(" "[" NOLOCKSHIFT))
        (48 ("r" "R" LOCKSHIFT))
        (49 ("t" "T" LOCKSHIFT))
        (50 ("g" "G" LOCKSHIFT))
        (51 ("y" "Y" LOCKSHIFT))
        (52 ("h" "H" LOCKSHIFT))
        (53 (56 "*" NOLOCKSHIFT))
        (54 ("n" "N" LOCKSHIFT))
        (55 ("m" "M" LOCKSHIFT))
        (56 LOCKDOWN . LOCKUP)
        (57 (32 32 NOLOCKSHIFT))
        (58 ("[" "{" NOLOCKSHIFT))
        (59 ("=" "+" NOLOCKSHIFT))
        (60 2SHIFTDOWN . 2SHIFTUP)
        (61 (195 195 NOLOCKSHIFT))
        (63 (")" "]" NOLOCKSHIFT))
        (77 EVENT . EVENT)
        (78 EVENT . EVENT)
        (79 EVENT . EVENT)
        (102 LOCKDOWN)
        (103 LOCKUP)))

(RPAQQ \DLIONKEYACTIONS
       ((2 (54 "^" NOLOCKSHIFT))
        (10 ("-" "_" NOLOCKSHIFT))
        (33 ("\" "|" NOLOCKSHIFT))
        (45 (96 "~" NOLOCKSHIFT))
        (OPEN METADOWN . METAUP)
        (PROP'S CTRLDOWN . CTRLUP)
        (SAME METADOWN . METAUP)
        (FIND ("2,3" "2,43" NOLOCKSHIFT))
        (UNDO ("2,4" "2,44" NOLOCKSHIFT))
        (STOP (5 7 NOLOCKSHIFT))
        (MOVE)
        (COPY)
        (AGAIN ("2,10" "2,50" NOLOCKSHIFT))
        (CENTER ("2,101" "2,141" NOLOCKSHIFT))
        (BOLD ("2,102" "2,142" NOLOCKSHIFT))
        (ITALICS ("2,103" "2,143" NOLOCKSHIFT))
        (UNDERLINE ("2,106" "2,146" NOLOCKSHIFT))
        (SUPERSCRIPT ("2,113" "2,153" NOLOCKSHIFT))
        (SUBSCRIPT ("2,114" "2,154" NOLOCKSHIFT))
        (LARGER ("2,110" "2,150" NOLOCKSHIFT))
        (DEFAULTS ("2,115" "2,155" NOLOCKSHIFT))
        (93 (27 "2,64" NOLOCKSHIFT))
        (47 ("2,22" "2,62" NOLOCKSHIFT))
        (31 ("2,5" "2,45" NOLOCKSHIFT))
        (92 ("2,1" "2,41" NOLOCKSHIFT))
        (80 ("2,13" "2,53" NOLOCKSHIFT))
        (FONT ("2,112" "2,152" NOLOCKSHIFT))))

(RPAQQ \DLIONOSDKEYACTIONS ((56 LOCKTOGGLE)))

(RPAQQ \DORADOKEYACTIONS
       ((2 (54 "~" NOLOCKSHIFT))
        (10 ("-" "-" NOLOCKSHIFT))
        (13 ("\" "|" NOLOCKSHIFT))
        (14 (10 96 NOLOCKSHIFT))
        (33 (27 27 NOLOCKSHIFT))
        (45 ("_" "^" NOLOCKSHIFT))))

(RPAQQ \DOVEKEYACTIONS
       ((2 (54 "^" NOLOCKSHIFT))
        (10 ("-" "_" NOLOCKSHIFT))
        (33 (27 27 NOLOCKSHIFT))
        (56 CTRLDOWN . CTRLUP)
        (65 (27 27 NOLOCKSHIFT))
        (71 (39 34 NOLOCKSHIFT))
        (93 ("2,24" "2,64" NOLOCKSHIFT))
        (108 (96 126 NOLOCKSHIFT))
        (DBK-META METADOWN . METAUP)
        (DBK-HELP ("2,1" "2,41" NOLOCKSHIFT))
        (SAME METADOWN . METAUP)
        (FIND ("2,3" "2,43" NOLOCKSHIFT))
        (UNDO ("2,4" "2,44" NOLOCKSHIFT))
        (STOP (5 7 NOLOCKSHIFT))
        (EDIT ("2,5" "2,45" NOLOCKSHIFT))
        (MOVE)
        (COPY)
        (AGAIN ("2,10" "2,50" NOLOCKSHIFT))
        (CENTER ("2,101" "2,141" NOLOCKSHIFT))
        (BOLD ("2,102" "2,142" NOLOCKSHIFT))
        (ITALICS ("2,103" "2,143" NOLOCKSHIFT))
        (CASE ("2,104" "2,144" NOLOCKSHIFT))
        (STRIKEOUT ("2,105" "2,145" NOLOCKSHIFT))
        (UNDERLINE ("2,106" "2,146" NOLOCKSHIFT))
        (SUPER/SUB ("2,107" "2,147" NOLOCKSHIFT))
        (LARGER ("2,110" "2,150" NOLOCKSHIFT))
        (MARGINS ("2,111" "2,151" NOLOCKSHIFT))
        (LOOKS ("2,112" "2,152" NOLOCKSHIFT))
        (CAPSLOCK LOCKTOGGLE)
        (NUMLOCK ("2,11" "-" NOLOCKSHIFT))
        (SCROLLLOCK ("2,12" 180 NOLOCKSHIFT))
        (BREAK (2 184 NOLOCKSHIFT))
        (DOIT ("2,13" "2,53" NOLOCKSHIFT))
        (KEYPAD7 ("2,14" 55 NOLOCKSHIFT))
        (KEYPAD8 (173 56 NOLOCKSHIFT))
        (KEYPAD9 ("2,15" 57 NOLOCKSHIFT))
        (KEYPAD4 (172 52 NOLOCKSHIFT))
        (KEYPAD5 ("2,16" 53 NOLOCKSHIFT))
        (KEYPAD6 (174 54 NOLOCKSHIFT))
        (KEYPAD1 ("2,17" 49 NOLOCKSHIFT))
        (KEYPAD2 (175 50 NOLOCKSHIFT))
        (KEYPAD3 ("2,20" 51 NOLOCKSHIFT))
        (KEYPAD0 ("2,21" 48 NOLOCKSHIFT))
        (KEYPAD%| ("|" 46 NOLOCKSHIFT))
        (KEYPAD\ ("\" 44 NOLOCKSHIFT))
        (47 ("2,22" "2,62" NOLOCKSHIFT))))

(RPAQQ \DOVEOSDKEYACTIONS ((56 LOCKDOWN . LOCKUP)
                               (36 CTRLDOWN . CTRLUP)
                               (CAPSLOCK ("2,5" "2,45" NOLOCKSHIFT))))

(RPAQQ \MAIKOKEYACTIONS
       ((61 (5 7 NOLOCKSHIFT))
        (91 (520 552 NOLOCKSHIFT))
        (92 (513 545 NOLOCKSHIFT))
        (30 (513 545 NOLOCKSHIFT))
        (63 (516 548 NOLOCKSHIFT))
        (93 (532 564 NOLOCKSHIFT))
        (62)
        (111 (329 263 NOLOCKSHIFT))
        (89)
        (90 (515 547 NOLOCKSHIFT))
        (73 (521 521 NOLOCKSHIFT))
        (74 (522 522 NOLOCKSHIFT))
        (75 (2 2 NOLOCKSHIFT))
        (81 (524 55 NOLOCKSHIFT))
        (82 (173 56 NOLOCKSHIFT))
        (83 (525 57 NOLOCKSHIFT))
        (84 (172 52 NOLOCKSHIFT))
        (85 (526 53 NOLOCKSHIFT))
        (87 (174 54 NOLOCKSHIFT))
        (94 (527 49 NOLOCKSHIFT))
        (69 (175 50 NOLOCKSHIFT))
        (70 (528 51 NOLOCKSHIFT))
        (98 (529 48 NOLOCKSHIFT))
        (76 (523 555 NOLOCKSHIFT))
        (72 LOCKTOGGLE)
        (97 (577 609 NOLOCKSHIFT))
        (99 (578 610 NOLOCKSHIFT))
        (100 (579 611 NOLOCKSHIFT))
        (67 (580 612 NOLOCKSHIFT))
        (68 (581 613 NOLOCKSHIFT))
        (101 (582 614 NOLOCKSHIFT))
        (66 (583 615 NOLOCKSHIFT))
        (104 (584 616 NOLOCKSHIFT))
        (80 (585 617 NOLOCKSHIFT))
        (13 (23 21 NOLOCKSHIFT))
        (33 (27 27 NOLOCKSHIFT))
        (65 (27 27 NOLOCKSHIFT))
        (2 (54 94 NOLOCKSHIFT))
        (10 (45 95 NOLOCKSHIFT))
        (36 CTRLDOWN . CTRLUP)
        (56 LOCKTOGGLE . IGNORE)
        (45 (96 126 NOLOCKSHIFT))
        (31 METADOWN . METAUP)
        (14 METADOWN . METAUP)
        (71 (10 10 NOLOCKSHIFT))
        (47 (530 562 NOLOCKSHIFT))
        (105 (92 124 NOLOCKSHIFT))))

(RPAQQ \MAIKOKEYACTIONST4
       ((61 ("^E" "^G" NOLOCKSHIFT))
        (91 ("2,10" "2,50" NOLOCKSHIFT))
        (92 ("2,1" "2,41" NOLOCKSHIFT))
        (30 ("2,1" "2,41" NOLOCKSHIFT))
        (109 ("2,25" "2,65" NOLOCKSHIFT))
        (63 ("2,4" "2,44" NOLOCKSHIFT))
        (14 METADOWN . METAUP)
        (93 ("2,24" "2,64" NOLOCKSHIFT))
        (62)
        (111 ("1,111" "1,79" NOLOCKSHIFT))
        (89)
        (90 ("2,3" "2,43" NOLOCKSHIFT))
        (73 ("2,11" "2,11" NOLOCKSHIFT))
        (74 ("2,12" "2,12" NOLOCKSHIFT))
        (75 ("^B" "^B" NOLOCKSHIFT))
        (81 ("2,14" 55 NOLOCKSHIFT))
        (82 (173 56 NOLOCKSHIFT))
        (83 ("2,15" 57 NOLOCKSHIFT))
        (84 (172 52 NOLOCKSHIFT))
        (85 ("2,16" 53 NOLOCKSHIFT))
        (87 (174 54 NOLOCKSHIFT))
        (94 ("2,17" 49 NOLOCKSHIFT))
        (69 (175 50 NOLOCKSHIFT))
        (70 ("2,20" 51 NOLOCKSHIFT))
        (98 ("2,21" 48 NOLOCKSHIFT))
        (76 ("2,13" "2,13" NOLOCKSHIFT))
        (110 ("2,53" "2,53" NOLOCKSHIFT))
        (72 LOCKTOGGLE)
        (97 ("2,101" "2,141" NOLOCKSHIFT))
        (99 ("2,102" "2,142" NOLOCKSHIFT))
        (100 ("2,103" "2,143" NOLOCKSHIFT))
        (67 ("2,104" "2,144" NOLOCKSHIFT))
        (68 ("2,105" "2,145" NOLOCKSHIFT))
        (101 ("2,106" "2,146" NOLOCKSHIFT))
        (66 ("2,107" "2,147" NOLOCKSHIFT))
        (104 ("2,110" "2,150" NOLOCKSHIFT))
        (80 ("2,111" "2,151" NOLOCKSHIFT))
        (106 ("2,113" "2,153" NOLOCKSHIFT))
        (107 ("2,114" "2,154" NOLOCKSHIFT))
        (108 ("2,115" "2,155" NOLOCKSHIFT))
        (13 ("^W" "^U" NOLOCKSHIFT))
        (33 ("ESC" "ESC" NOLOCKSHIFT))
        (64 IGNORE . IGNORE)
        (65 (27 27 NOLOCKSHIFT))
        (95 IGNORE . IGNORE)
        (96 IGNORE . IGNORE)
        (102 IGNORE . IGNORE)
        (2 ("6" "^" NOLOCKSHIFT))
        (10 ("-" "_" NOLOCKSHIFT))
        (36 CTRLDOWN . CTRLUP)
        (56 LOCKTOGGLE . IGNORE)
        (45 ("`" "~" NOLOCKSHIFT))
        (31 METADOWN . METAUP)
        (71 (10 10 NOLOCKSHIFT))
        (47 ("2,22" "2,62" NOLOCKSHIFT))
        (86 IGNORE . IGNORE)
        (88 IGNORE . IGNORE)
        (105 ("\" "|" NOLOCKSHIFT))))

(RPAQQ \MAIKO-JLE-KEYACTIONS
       ((2 ("6" "&" NOLOCKSHIFT))
        (4 ("7" "'" NOLOCKSHIFT))
        (8 ("0" "0" NOLOCKSHIFT))
        (10 ("\" "_" NOLOCKSHIFT))
        (13 ("^W" "^U" NOLOCKSHIFT))
        (14 METADOWN . METAUP)
        (15 (8 8 NOLOCKSHIFT))
        (17 ("2" "%"" NOLOCKSHIFT))
        (22 ("9" ")" NOLOCKSHIFT))
        (28 (":" "*" NOLOCKSHIFT))
        (29 ("[" "{" NOLOCKSHIFT))
        (30 ("]" "}" NOLOCKSHIFT))
        (31 METADOWN . METAUP)
        (33 ("ESC" "ESC" NOLOCKSHIFT))
        (36 CTRLDOWN . CTRLUP)
        (43 (";" "+" NOLOCKSHIFT))
        (45 ("^" "~" NOLOCKSHIFT))
        (47 ("2,22" "2,62" NOLOCKSHIFT))
        (53 ("8" "(" NOLOCKSHIFT))
        (56 LOCKTOGGLE . IGNORE)
        (58 ("@" "`" NOLOCKSHIFT))
        (59 ("-" "=" NOLOCKSHIFT))
        (61 ("^E" "^G" NOLOCKSHIFT))
        (62)
        (63 ("2,4" "2,44" NOLOCKSHIFT))
        (64 ("2,14" 55 NOLOCKSHIFT))
        (65 (27 27 NOLOCKSHIFT))
        (66 ("2,107" "2,147" NOLOCKSHIFT))
        (67 ("2,104" "2,144" NOLOCKSHIFT))
        (69 ("2,13" "2,53" NOLOCKSHIFT))
        (70 ("2,20" 51 NOLOCKSHIFT))
        (71 (10 10 NOLOCKSHIFT))
        (72 (766 766 NOLOCKSHIFT))
        (73 ("2,11" "2,11" NOLOCKSHIFT))
        (74 ("2,12" "2,12" NOLOCKSHIFT))
        (75 ("^B" "^B" NOLOCKSHIFT))
        (80 ("2,111" "2,151" NOLOCKSHIFT))
        (81 ("2,14" 55 NOLOCKSHIFT))
        (82 (173 56 NOLOCKSHIFT))
        (83 ("2,15" 57 NOLOCKSHIFT))
        (84 (172 52 NOLOCKSHIFT))
        (85 ("2,16" 53 NOLOCKSHIFT))
        (86 (765 765 NOLOCKSHIFT))
        (87 (174 54 NOLOCKSHIFT))
        (88 (770 771 NOLOCKSHIFT))
        (90 ("2,3" "2,43" NOLOCKSHIFT))
        (91 ("2,10" "2,50" NOLOCKSHIFT))
        (92 ("2,1" "2,41" NOLOCKSHIFT))
        (93 ("2,24" "2,64" NOLOCKSHIFT))
        (96 IGNORE . IGNORE)
        (98 ("2,21" 48 NOLOCKSHIFT))
        (99 ("2,102" "2,142" NOLOCKSHIFT))
        (101 ("2,106" "2,146" NOLOCKSHIFT))
        (102 IGNORE . IGNORE)
        (103 (767 768 NOLOCKSHIFT))
        (104 ("2,110" "2,150" NOLOCKSHIFT))
        (105 ("\" "|" NOLOCKSHIFT))
        (106 ("2,113" "2,153" NOLOCKSHIFT))
        (107 ("2,114" "2,154" NOLOCKSHIFT))
        (108 ("2,115" "2,155" NOLOCKSHIFT))
        (109 (769 769 NOLOCKSHIFT))
        (110 ("2,53" "2,53" NOLOCKSHIFT))
        (111 ("1,111" "1,79" NOLOCKSHIFT))))

(RPAQQ \TOSHIBA-KEYACTIONS
       ((2 ("6" "&" NOLOCKSHIFT))
        (4 ("7" "'" NOLOCKSHIFT))
        (17 ("2" "%"" NOLOCKSHIFT))
        (53 ("8" "(" NOLOCKSHIFT))
        (22 ("9" ")" NOLOCKSHIFT))
        (8 ("0" "0" NOLOCKSHIFT))
        (10 ("-" "=" NOLOCKSHIFT))
        (59 ("^" "~" NOLOCKSHIFT))
        (45 ("\" "|" NOLOCKSHIFT))
        (58 ("@" "`" NOLOCKSHIFT))
        (29 ("[" "{" NOLOCKSHIFT))
        (105 ("]" "}" NOLOCKSHIFT))
        (43 (";" "+" NOLOCKSHIFT))
        (28 (":" "*" NOLOCKSHIFT))
        (15 (23 95 NOLOCKSHIFT))
        (13 (8 8 NOLOCKSHIFT))
        (86 METADOWN . METAUP)
        (73 (530 562 NOLOCKSHIFT))
        (88 ("2,24" "2,64" NOLOCKSHIFT))
        (98 IGNORE . IGNORE)
        (75 ("2,11" "2,11" NOLOCKSHIFT))
        (110 ("2,12" "2,12" NOLOCKSHIFT))
        (74 ("^B" "^B" NOLOCKSHIFT))
        (64 ("2,14" 55 NOLOCKSHIFT))
        (65 (173 56 NOLOCKSHIFT))
        (95 ("2,15" 57 NOLOCKSHIFT))
        (81 (172 52 NOLOCKSHIFT))
        (82 ("2,16" 53 NOLOCKSHIFT))
        (83 (174 54 NOLOCKSHIFT))
        (84 ("2,17" 49 NOLOCKSHIFT))
        (85 (175 50 NOLOCKSHIFT))
        (87 ("2,20" 51 NOLOCKSHIFT))
        (94 ("2,21" 48 NOLOCKSHIFT))
        (69 ("2,13" "2,53" NOLOCKSHIFT))
        (70 LOCKTOGGLE)))

(RPAQQ KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS NIL)

(RPAQ? \KEYBOARD.META 256)

(RPAQ? \MODIFIED.KEYACTIONS )
(DECLARE%: EVAL@COMPILE 

(ADDTOVAR GLOBALVARS \RCLKSECOND \LASTUSERACTION \LASTKEYSTATE)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \SYSBUFFER \LONGSYSBUF \INTERRUPTSTATE \MODIFIED.KEYACTIONS \MOUSECHORDTICKS 
       \KEYBOARDEVENTQUEUE \KEYBUFFERING \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION 
       \TIMER.INTERRUPT.PENDING \ORIGKEYACTIONS \KEYBOARD.META \MOUSECHORDMILLISECONDS 
       \DORADOKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DOVEKEYACTIONS \DOVEOSDKEYACTIONS)
)



(* ; "Key interpretation")

(DEFINEQ

(KEYACTION
  [LAMBDA (KEYNAME ACTIONS TABLE)                        (* ; "Edited 19-Nov-87 16:19 by Snow")
    (LET ((NUMB (OR (SMALLP KEYNAME)
                    (\KEYNAMETONUMBER KEYNAME)))
          (TABLE (OR TABLE \CURRENTKEYACTION)))
         (OR (TYPE? KEYACTION TABLE)
             (\ILLEGAL.ARG TABLE))                           (* ; 
                                                    "Make sure he supplied a valid TABLE argument.")
         (CONS (\KEYACTION1 (\TRANSINDEX NUMB T)
                      (AND ACTIONS (OR (CAR ACTIONS)
                                       'IGNORE))
                      TABLE)
               (\KEYACTION1 (\TRANSINDEX NUMB NIL)
                      (AND ACTIONS (OR (CDR ACTIONS)
                                       'IGNORE))
                      TABLE])

(KEYACTIONTABLE
  [LAMBDA (OLD)                                      (* ; "Edited 23-Mar-92 12:44 by jds")

    (* ;; "Create a fresh key action table (or copy OLD so it can be modified without danger).  Returns a fresh keyaction table.")

    (COND
       (OLD 

              (* ;; "He supplied an existing table; create a copy of it:")

              (OR (type? KEYACTION OLD)
                  (\ILLEGAL.ARG OLD))                        (* ; 
                                                    "Make sure the argument IS a key action table.")
              (create KEYACTION copying OLD))
       (T 
          (* ;; "Create a completely fresh table, filled in from \ORIGKEYACTIONS, and the machine-specific exceptions:")

          (PROG1 (SETQ OLD (create KEYACTION))
              (for X in (APPEND (COPY \ORIGKEYACTIONS)
                                       (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS)
                                       KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS)
                 do (KEYACTION (CAR X)
                               (CDR X)
                               OLD)))])

(KEYBOARDTYPE
  [LAMBDA NIL                                                (* ; "Edited  6-Nov-95 15:35 by ")
                                                             (* ; "Edited 17-Feb-95 14:36 by rmk:")
                                                             (* ; 
                                                           "Edited 16-Jun-92 11:03 by kaplan")

    (* ;; "Returns a symbol identifying the currently connected keyboard type.  For now, infers it from the machine type, defaults to NIL (= unknown).")

    (LET ((MT (MACHINETYPE)))
         (SELECTQ MT
             (MAIKO (OR [CADR (SASSOC (L-CASE (UNIX-GETENV "LDEKBDTYPE"))
                                     '(("type3" SUN3)
                                       ("type4" SUN4)
                                       ("type5" SUN5]
                        (MKATOM (U-CASE (UNIX-GETENV "LDEKBDTYPE")))
                        (AND (STREQUAL "dos" (UNIX-GETPARM "ARCH"))
                             'FULL-IBMPC)))
             ((DORADO DANDELION DOVE) 
                  MT)
             NIL])

(RESETKEYACTION
  [LAMBDA (TABLE FROM RESETINTERRUPTS)                   (* ; "Edited 19-Nov-87 16:55 by Snow")

    (* ;; "Resets the actions of key transitions in the keyaction table TABLE, copying in the actions from FROM.  If RESETINTERRUPTS is true, also copies the interrupt-character settings from FROM.")

    (DECLARE (GLOBALVARS \DEFAULTKEYACTION))
    (* ;; "do some type checking first.")

    (OR (type? KEYACTION TABLE)
        (\ILLEGAL.ARG TABLE))
    (OR FROM (SETQ FROM \DEFAULTKEYACTION))
    (OR (type? KEYACTION FROM)
        (\ILLEGAL.ARG TABLE))
    (* ;; "do the resetting.")

    (\BLT (fetch (KEYACTION FLAGS) of TABLE)
          (fetch (KEYACTION FLAGS) of FROM)
          (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION FLAGS) of TABLE))
                1))
    (\BLT (fetch (KEYACTION CODES) of TABLE)
          (fetch (KEYACTION CODES) of FROM)
          (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION CODES) of TABLE))
                1))
    (\BLT (fetch (KEYACTION SHIFTCODES) of TABLE)
          (fetch (KEYACTION SHIFTCODES) of FROM)
          (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION SHIFTCODES) of TABLE))
                1))
    [if RESETINTERRUPTS
        then (\BLT (fetch (KEYACTION ARMED) of TABLE)
                       (fetch (KEYACTION ARMED) of FROM)
                       (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION ARMED) of TABLE))
                             1))
              (replace (KEYACTION INTERRUPTLIST) of TABLE
                 with (COPY (fetch (KEYACTION INTERRUPTLIST) of FROM]
    TABLE])

(\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS
  [LAMBDA NIL                                            (* ; "Edited 18-Sep-90 22:36 by jds")

    (* ;; 
  "Return a list of machine-specific keyactions appropriate to the machine you're running on.")

    (* ;; "Also take account (on Maiko implementations) of whether we're running under X or not -- the CAPS-LOCK key works differently.")

    (SELECTC \MACHINETYPE
        (\DORADO \DORADOKEYACTIONS)
        (\DANDELION \DLIONKEYACTIONS)
        (\MAIKO (LET [(CAPS-LOCK-ACTIONS (COND
                                            ((EQUAL (UNIX-GETPARM "DISPLAY")
                                                    "X")
                                             '((56 LOCKDOWN . LOCKUP)
                                               (72 LOCKDOWN . LOCKUP]

                     (* ;; "If we're running under X windows, CAPS-LOCK-ACTIONS, appended to the normal keyactions, will reset the keyboard appropriately.")

                     (COND
                        ((EQUAL \SUN.TYPE3KEYBOARD (LOGAND 7 (fetch (IFPAGE DEVCONFIG)
                                                                of \InterfacePage)))
                         (APPEND \MAIKOKEYACTIONS CAPS-LOCK-ACTIONS))
                        ((EQUAL \SUN.TYPE4KEYBOARD (LOGAND 7 (fetch (IFPAGE DEVCONFIG)
                                                                of \InterfacePage)))
                         (APPEND \MAIKOKEYACTIONST4 CAPS-LOCK-ACTIONS))
                        ((EQUAL \SUN.JLEKEYBOARD (LOGAND 7 (fetch (IFPAGE DEVCONFIG) of
                                                                                         
                                                                                       \InterfacePage
                                                                  )))
                         \MAIKO-JLE-KEYACTIONS)
                        ((EQUAL \TOSHIBA.JIS (LOGAND 7 (FETCH (IFPAGE DEVCONFIG) OF 
                                                                                       \InterfacePage
                                                              )))
                                                             (* ; "Toshiba JIS")
                         (APPEND \MAIKOKEYACTIONST4 \TOSHIBA-KEYACTIONS))
                        (T                                   (* ; "default is type3")
                           \MAIKOKEYACTIONS))))
        (\DAYBREAK                                           (* ; 
                  "Moving to a daybreak.  Need to distinguish among the various kinds of keyboard.")

                   (* ;; "For now, we only distinguish between the office keyboards (1 = US, 2 = Euro, 3 = Japanese, 4 = ADM-3), and some yet-to-be-determined Lisp-keyboard number")

                   (COND
                      ((ILEQ (\DoveMisc.ReadKeyboardType)
                             4)                              (* ; 
                                                       "It's an office keyboard.  Set it up right!")
                       (APPEND \DOVEKEYACTIONS \DOVEOSDKEYACTIONS))
                      (T                                     (* ; 
                                          "Lisp keyboard.  Leave the Dove keyactions as they were.")
                         \DOVEKEYACTIONS)))
        NIL])

(\KEYACTION1
  [LAMBDA (TI ACTION TABLE)                              (* ; "Edited  4-Mar-92 13:59 by jds")
    (PROG1 (SELECTC (TRANSITIONFLAGS TABLE TI)
               (IGNORE.TF 'IGNORE)
               ((LIST LOCKSHIFT.TF NOLOCKSHIFT.TF) 
                    [LET (CODE)
                         (LIST (CHECKFORDEADKEY (TRANSITIONCODE TABLE TI)
                                      TABLE TI NIL)
                               (CHECKFORDEADKEY (TRANSITIONSHIFTCODE TABLE TI)
                                      TABLE TI T)
                               (TRANSITIONALTGRCODE TABLE TI)
                               (COND
                                  ((EQ LOCKSHIFT.TF (TRANSITIONFLAGS TABLE TI))
                                   'LOCKSHIFT)
                                  (T 'NOLOCKSHIFT])
               (EVENT.TF 'EVENT)
               (CTRLDOWN.TF 'CTRLDOWN)
               (CTRLUP.TF 'CTRLUP)
               (DEADKEY.TF (LIST 'DEADKEY (TRANSITIONDEADLIST TABLE TI)
                                 (TRANSITIONDEADLIST TABLE TI T)))
               (1SHIFTDOWN.TF '1SHIFTDOWN)
               (1SHIFTUP.TF '1SHIFTUP)
               (2SHIFTDOWN.TF '2SHIFTDOWN)
               (2SHIFTUP.TF '2SHIFTUP)
               (LOCKDOWN.TF 'LOCKDOWN)
               (LOCKUP.TF 'LOCKUP)
               (LOCKTOGGLE.TF 'LOCKTOGGLE)
               (METADOWN.TF 'METADOWN)
               (METAUP.TF 'METAUP)
               (FONTUP.TF 'FONTUP)
               (FONTDOWN.TF 'FONTDOWN)
               (FONTTOGGLE.TF 'FONTTOGGLE)
               (USERMODE1UP.TF 
                    'USERMODE1UP)
               (USERMODE1DOWN.TF 
                    'USERMODE1DOWN)
               (USERMODE1TOGGLE.TF 
                    'USERMODE1TOGGLE)
               (USERMODE2UP.TF 
                    'USERMODE2UP)
               (USERMODE2DOWN.TF 
                    'USERMODE2DOWN)
               (USERMODE2TOGGLE.TF 
                    'USERMODE2TOGGLE)
               (USERMODE3UP.TF 
                    'USERMODE3UP)
               (USERMODE3DOWN.TF 
                    'USERMODE3DOWN)
               (USERMODE3TOGGLE.TF 
                    'USERMODE3TOGGLE)
               (ALTGRUP.TF 'ALTGRUP)
               (ALTGRDOWN.TF 'ALTGRDOWN)
               (ALTGRTOGGLE.TF 
                    'ALTGRTOGGLE)
               (SHOULDNT))
        [SELECTQ ACTION
            ((NIL NOCHANGE))
            (IGNORE (change (TRANSITIONFLAGS TABLE TI)
                           IGNORE.TF))
            (EVENT (change (TRANSITIONFLAGS TABLE TI)
                          EVENT.TF))
            (CTRLUP (change (TRANSITIONFLAGS TABLE TI)
                           CTRLUP.TF))
            (CTRLDOWN (change (TRANSITIONFLAGS TABLE TI)
                             CTRLDOWN.TF))
            (1SHIFTUP (change (TRANSITIONFLAGS TABLE TI)
                             1SHIFTUP.TF))
            (1SHIFTDOWN (change (TRANSITIONFLAGS TABLE TI)
                               1SHIFTDOWN.TF))
            (2SHIFTUP (change (TRANSITIONFLAGS TABLE TI)
                             2SHIFTUP.TF))
            (2SHIFTDOWN (change (TRANSITIONFLAGS TABLE TI)
                               2SHIFTDOWN.TF))
            (LOCKUP (change (TRANSITIONFLAGS TABLE TI)
                           LOCKUP.TF))
            (LOCKDOWN (change (TRANSITIONFLAGS TABLE TI)
                             LOCKDOWN.TF))
            (LOCKTOGGLE (change (TRANSITIONFLAGS TABLE TI)
                               LOCKTOGGLE.TF))
            (METAUP (change (TRANSITIONFLAGS TABLE TI)
                           METAUP.TF))
            (METADOWN (change (TRANSITIONFLAGS TABLE TI)
                             METADOWN.TF))
            (FONTUP (change (TRANSITIONFLAGS TABLE TI)
                           FONTUP.TF))
            (FONTDOWN (change (TRANSITIONFLAGS TABLE TI)
                             FONTDOWN.TF))
            (FONTTOGGLE (change (TRANSITIONFLAGS TABLE TI)
                               FONTTOGGLE.TF))
            (USERMODE1UP (change (TRANSITIONFLAGS TABLE TI)
                                USERMODE1UP.TF))
            (USERMODE1DOWN (change (TRANSITIONFLAGS TABLE TI)
                                  USERMODE1DOWN.TF))
            (USERMODE1TOGGLE 
                 (change (TRANSITIONFLAGS TABLE TI)
                        USERMODE1TOGGLE.TF))
            (USERMODE2UP (change (TRANSITIONFLAGS TABLE TI)
                                USERMODE2UP.TF))
            (USERMODE2DOWN (change (TRANSITIONFLAGS TABLE TI)
                                  USERMODE2DOWN.TF))
            (USERMODE2TOGGLE 
                 (change (TRANSITIONFLAGS TABLE TI)
                        USERMODE2TOGGLE.TF))
            (USERMODE3UP (change (TRANSITIONFLAGS TABLE TI)
                                USERMODE3UP.TF))
            (USERMODE3DOWN (change (TRANSITIONFLAGS TABLE TI)
                                  USERMODE3DOWN.TF))
            (USERMODE3TOGGLE 
                 (change (TRANSITIONFLAGS TABLE TI)
                        USERMODE3TOGGLE.TF))
            (ALTGRUP (change (TRANSITIONFLAGS TABLE TI)
                            ALTGRUP.TF))
            (ALTGRDOWN (change (TRANSITIONFLAGS TABLE TI)
                              ALTGRDOWN.TF))
            (ALTGRTOGGLE (change (TRANSITIONFLAGS TABLE TI)
                                ALTGRTOGGLE.TF))
            (PROG (CODE SHIFTCODE ALTGRCODE ACT DEAD SHIFTDEAD)
                  (COND
                     ([AND [OR (AND (AND (LISTP (CAR (LISTP ACTION)))
                                         (EQ (CAAR (LISTP ACTION))
                                             'DEADKEY))
                                    [SETQ DEAD
                                     (for PAIR in (CADAR (LISTP ACTION))
                                        collect 

                                              (* ;; 
                                  "Make sure we'll take string charcode specs in the deadkey list.")

                                              (CONS (OR (AND (\CHARCODEP (CAR PAIR))
                                                             (CAR PAIR))
                                                        (APPLY* (FUNCTION CHARCODE)
                                                               (CAR PAIR)))
                                                    (OR (AND (\CHARCODEP (CDR PAIR))
                                                             (CDR PAIR))
                                                        (APPLY* (FUNCTION CHARCODE)
                                                               (CDR PAIR]
                                    (SETQ CODE 65535))
                               [\CHARCODEP (SETQ CODE (\GETCHARCODE (CAR (LISTP ACTION]
                               (SETQ CODE (APPLY* (FUNCTION CHARCODE)
                                                 (CAR (LISTP ACTION]
                           [OR (AND (AND (LISTP (CADR (LISTP ACTION)))
                                         (EQ (CAADR (LISTP ACTION))
                                             'DEADKEY))
                                    [SETQ SHIFTDEAD
                                     (for PAIR in (CADADR (LISTP ACTION))
                                        collect (CONS (OR (AND (\CHARCODEP (CAR PAIR))
                                                                   (CAR PAIR))
                                                              (APPLY* (FUNCTION CHARCODE)
                                                                     (CAR PAIR)))
                                                          (OR (AND (\CHARCODEP (CDR PAIR))
                                                                   (CDR PAIR))
                                                              (APPLY* (FUNCTION CHARCODE)
                                                                     (CDR PAIR]
                                    (SETQ SHIFTCODE 65535)
                                    (SETQ ACT (CDR ACTION)))
                               [\CHARCODEP (SETQ SHIFTCODE (\GETCHARCODE (CAR (SETQ ACT
                                                                               (LISTP (CDR ACTION]
                               (SETQ SHIFTCODE (APPLY* (FUNCTION CHARCODE)
                                                      (CAR ACT]
                           (OR (NULL (SETQ ACT (CDR ACT)))
                               (LISTP ACT))
                           (SELECTQ (CAR ACT)
                               ((LOCKSHIFT T) 
                                    (change (TRANSITIONFLAGS TABLE TI)
                                           LOCKSHIFT.TF))
                               ((NOLOCKSHIFT NIL) 
                                    (change (TRANSITIONFLAGS TABLE TI)
                                           NOLOCKSHIFT.TF))
                               (AND [OR [\CHARCODEP (SETQ ALTGRCODE (\GETCHARCODE (CAR ACT]
                                        (SETQ ALTGRCODE (APPLY* (FUNCTION CHARCODE)
                                                               (CAR ACT]
                                    (OR (NULL (SETQ ACT (CDR ACT)))
                                        (LISTP ACT))
                                    (SELECTQ (CAR ACT)
                                        ((LOCKSHIFT T) 
                                             (change (TRANSITIONFLAGS TABLE TI)
                                                    LOCKSHIFT.TF))
                                        ((NOLOCKSHIFT NIL) 
                                             (change (TRANSITIONFLAGS TABLE TI)
                                                    NOLOCKSHIFT.TF))
                                        NIL]
                      (change (TRANSITIONCODE TABLE TI)
                             CODE)
                      (change (TRANSITIONSHIFTCODE TABLE TI)
                             SHIFTCODE)
                      (\RPLPTR (fetch (KEYACTION DEADKEYLIST) of TABLE)
                             (LLSH TI 1)
                             DEAD)
                      (\RPLPTR (fetch (KEYACTION DEADKEYLIST) of TABLE)
                             (LLSH (IPLUS \NKEYS \NKEYS TI)
                                   1)
                             SHIFTDEAD)
                      (AND ALTGRCODE (change (TRANSITIONALTGRCODE TABLE TI)
                                            ALTGRCODE)))
                     (T (\ILLEGAL.ARG ACTION])])

(KEYDOWNP
  [LAMBDA (KEYNAME)                                      (* lmm "18-Apr-85 02:09")
                                                             (* T if the indicated key is 
                                                           instantaneously down.)
    (\NEWKEYDOWNP (\KEYNAMETONUMBER KEYNAME])

(KEYNUMBERP
  [LAMBDA (X)                                                (* ; "Edited 16-Jan-96 13:16 by rmk")
    (AND (SMALLP X)
         (IGEQ X 0)
         (ILESSP X \NKEYS)
         X])

(\KEYNAMETONUMBER
  [LAMBDA (KEYNAME)                                      (* rmk%: " 2-SEP-83 10:29")
    (DECLARE (GLOBALVARS \KEYNAMES))                     (* The fast case is when KEYNAME is 
                                                           lower-case)
    (for X N in \KEYNAMES as I from 0 when (EQMEMB KEYNAME X)
       do (RETURN I)
       finally (RETURN (OR (AND (NEQ KEYNAME (SETQ N (L-CASE KEYNAME)))
                                    (for Y in \KEYNAMES as I from 0
                                       when (EQMEMB N Y) do (RETURN I)))
                               (\ILLEGAL.ARG KEYNAME])

(MODIFY.KEYACTIONS
  [LAMBDA (KeyActions SaveCurrent?)                    (* ; "Edited  2-Feb-89 15:38 by GADENER")
    (PROG1 [if SaveCurrent?
               then (SETQ \MODIFIED.KEYACTIONS (for ITEM in KeyActions
                                                      collect (CONS (CAR ITEM)
                                                                        (KEYACTION (CAR ITEM]
        [for action in KeyActions do (for table in '(\CURRENTKEYACTION 
                                                                               \COMMANDKEYACTION)
                                                    do (KEYACTION (CAR action)
                                                                  (CDR action)
                                                                  (EVAL table])])

(METASHIFT
  [LAMBDA FLG                                            (* ; "Edited 19-Nov-87 16:59 by Snow")

    (* ;; "Sets interpretation of swat key to first arg, where T means meta-shift, NIL means original setting.  Returns previous setting")

    (PROG ((METASTATUS '(METADOWN . METAUP))
           OLDSETTING)
          [SETQ OLDSETTING (KEYACTION 'BLANK-BOTTOM
                                  (AND (IGREATERP FLG 0)
                                       (COND
                                          ((EQ (ARG FLG 1)
                                               T)
                                           METASTATUS)
                                          (T (OR (ARG FLG 1)
                                                 (CDR (ASSOC 'BLANK-BOTTOM \ORIGKEYACTIONS]
          (RETURN (COND
                     ((EQUAL OLDSETTING METASTATUS)
                      T)
                     (T OLDSETTING])

(SHIFTDOWNP
  [LAMBDA (SHIFT)                                        (* lmm "18-Apr-85 01:07")
                                                             (* Tells whether a given shift is 
                                                           down)
    (SELECTQ SHIFT
        (LOCK (fetch (KEYBOARDEVENT LOCK) of \LASTKEYSTATE))
        (META (fetch (KEYBOARDEVENT META) of \LASTKEYSTATE))
        (SHIFT (OR (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE)
                   (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE)))
        (1SHIFT (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE))
        (2SHIFT (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE))
        (SHIFTORLOCK (OR (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE)
                         (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE)
                         (fetch (KEYBOARDEVENT LOCK) of \LASTKEYSTATE)))
        (CTRL (fetch (KEYBOARDEVENT CTRL) of \LASTKEYSTATE))
        (FONT (fetch (KEYBOARDEVENT FONT) of \LASTKEYSTATE))
        (USERMODE1 (fetch (KEYBOARDEVENT USERMODE1) of \LASTKEYSTATE))
        (USERMODE2 (fetch (KEYBOARDEVENT USERMODE2) of \LASTKEYSTATE))
        (USERMODE3 (fetch (KEYBOARDEVENT USERMODE3) of \LASTKEYSTATE))
        (\ILLEGAL.ARG SHIFT])
)



(* ; "To support office style 1108 & 1186 keyboards")

(DEFINEQ

(SETUP.OFFICE.KEYBOARD
  [LAMBDA NIL                                            (* jds " 8-Oct-85 16:27")
    (SELECTQ (MACHINETYPE)
        (DANDELION (MODIFY.KEYACTIONS \DLIONOSDKEYACTIONS))
        (DOVE (MODIFY.KEYACTIONS \DOVEOSDKEYACTIONS))
        NIL])
)

(DEFOPTIMIZER \KEYNAMETONUMBER (&REST X)
                                   [LET [(CE (CONSTANTEXPRESSIONP (CAR X]
                                        (COND
                                           (CE (\KEYNAMETONUMBER (CAR CE)))
                                           (T 'IGNOREMACRO])
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \TEMPCOPYTIMER MACRO ((X)
                                        (PROGN (\BLT \MOUSETIMERTEMP (LOCF X)
                                                     WORDSPERCELL)
                                               \MOUSETIMERTEMP)))
)



(* ; "Don't copy this optimizer since it expands out to \getbasebit, but do exportit.")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")
(DEFOPTIMIZER KEYDOWNP (KEYNAME)
                           `(\NEWKEYDOWNP (\KEYNAMETONUMBER ,KEYNAME)))

(* "END EXPORTED DEFINITIONS")

)
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS XKEYDOWNP MACRO ((KEYNAME)
                                   (KEYDOWNP1 (\KEYNAMETONUMBER KEYNAME))))

(PUTPROPS KEYDOWNP1 MACRO
          [OPENLAMBDA (KEYNUMBER)
            (DECLARE (GLOBALVARS \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.UTILIN 
                                \EM.KBDAD4 \EM.KBDAD5))
            (PROG NIL
                  (RETURN (EQ 0 (LOGAND (LRSH (LLSH 1 15)
                                              (PROGN         (* (IMOD KEYNUMBER BITSPERWORD) -
                                                           GETD cause IMOD and BITSPERWORD not 
                                                           exported to user)
                                                     (LOGAND KEYNUMBER 15)))
                                       (\GETBASE (SELECTQ (PROGN 
                                                             (* (FOLDLO KEYNUMBER BITSPERWORD) 
                                                           GETD follows since FOLDLO and 
                                                           BITSPERWORD not exported to user)
                                                                 (LRSH KEYNUMBER 4))
                                                     (0 \EM.KBDAD0)
                                                     (1 \EM.KBDAD1)
                                                     (2 \EM.KBDAD2)
                                                     (3 \EM.KBDAD3)
                                                     (4 \EM.UTILIN)
                                                     (5 (OR \EM.KBDAD4 (RETURN)))
                                                     (6 (OR \EM.KBDAD5 (RETURN)))
                                                     (RETURN))
                                              0])

(PUTPROPS \NEWKEYDOWNP MACRO ((KEYNUMBER)
                                      (EQ 0 (\GETBASEBIT \LASTKEYSTATE KEYNUMBER))))
)

(* "END EXPORTED DEFINITIONS")




(* ; "A raw keyboard device/stream")

(DEFINEQ

(\INIT.KEYBOARD.STREAM
  [LAMBDA NIL                                            (* ; "Edited  4-Sep-87 10:25 by jds")

    (* ;; "Initialize the %"Keyboard%" device:  Set up the FDEV and the prototype keyboard stream in their respective global variables.")

    (DECLARE (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM))
    [\DEFINEDEVICE 'KEYBOARD (SETQ \KEYBOARD.DEVICE (create FDEV
                                                           DEVICENAME _ 'KEYBOARD
                                                           CLOSEFILE _ (FUNCTION NILL)
                                                           EVENTFN _ (FUNCTION \KEYBOARDEVENTFN)
                                                           BIN _ (FUNCTION \GETKEY)
                                                           PEEKBIN _ (FUNCTION \PEEKSYSBUF)
                                                           READP _ (FUNCTION \SYSBUFP)
                                                           EOFP _ (FUNCTION NILL)
                                                           GETFILENAME _
                                                           (FUNCTION (LAMBDA (X MODE)
                                                                       (if (EQ MODE 'INPUT)
                                                                           then \KEYBOARD.STREAM]
    (SETQ \KEYBOARD.STREAM (create STREAM
                                  USERCLOSEABLE _ NIL
                                  USERVISIBLE _ NIL
                                  FULLFILENAME _ '{KEYBOARD}
                                  DEVICE _ \KEYBOARD.DEVICE
                                  ACCESS _ 'INPUT])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\INIT.KEYBOARD.STREAM)
)
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM)
)

(* "END EXPORTED DEFINITIONS")




(* ; "Hook for a periodic interrupt")

(DEFINEQ

(\DOBUFFEREDTRANSITIONS
  [LAMBDA (\INTERRUPTABLE)
    (DECLARE (SPECVARS \INTERRUPTABLE))              (* ; "Edited  1-Feb-92 11:59 by jds")
    (SETQ \KEYBUFFERING 'INPROGRESS)
    (LET ((PENDINGINTERRUPT))
         (DECLARE (SPECVARS PENDINGINTERRUPT))           (* ; "Used by \DECODETRANSITION")
         [bind R RPTR until (EQ 0 (SETQ R (fetch (RING READ) of \KEYBOARDEVENTQUEUE))
                                        ) do (SETQ RPTR (\ADDBASE \KEYBOARDEVENTQUEUE R)) 
                                                             (* ; "get pointer to this event")
                                                             (* ; 
                             "handle simple keyboard words by calling \DOTRANSITIONS for each word")
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W0) of RPTR)
                                                         (fetch (KEYBOARDEVENT W0) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 0 (fetch (KEYBOARDEVENT
                                                                                      W0)
                                                                             of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W0) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W0) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W0)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W1) of RPTR)
                                                         (fetch (KEYBOARDEVENT W1) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 16 (fetch (KEYBOARDEVENT
                                                                                       W1)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W1) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W1) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W1)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W2) of RPTR)
                                                         (fetch (KEYBOARDEVENT W2) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 32 (fetch (KEYBOARDEVENT
                                                                                       W2)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W2) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W2) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W2)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W3) of RPTR)
                                                         (fetch (KEYBOARDEVENT W3) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 48 (fetch (KEYBOARDEVENT
                                                                                       W3)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W3) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W3) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W3)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W4) of RPTR)
                                                         (fetch (KEYBOARDEVENT W4) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 80 (fetch (KEYBOARDEVENT
                                                                                       W4)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W4) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W4) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W4)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT W5) of RPTR)
                                                         (fetch (KEYBOARDEVENT W5) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 96 (fetch (KEYBOARDEVENT
                                                                                       W5)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT W5) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT W5) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT W5)
                                                                   of RPTR]
                                                [COND
                                                   ((NEQ (fetch (KEYBOARDEVENT WU) of RPTR)
                                                         (fetch (KEYBOARDEVENT WU) of 
                                                                                        \LASTKEYSTATE
                                                                ))
                                                    (\DOTRANSITIONS 64 (fetch (KEYBOARDEVENT
                                                                                       WU)
                                                                              of \LASTKEYSTATE)
                                                           (fetch (KEYBOARDEVENT WU) of
                                                                                         RPTR))
                                                    (replace (KEYBOARDEVENT WU) of 
                                                                                        \LASTKEYSTATE
                                                       with (fetch (KEYBOARDEVENT WU)
                                                                   of RPTR] 

(* ;;; "now remove event from queue")

                                                (COND
                                                   ((EQ [replace (RING READ) of 
                                                                                  \KEYBOARDEVENTQUEUE
                                                           with (COND
                                                                       ((IGEQ R \KEYBOARDEVENT.LAST)
                                                                        \KEYBOARDEVENT.FIRST)
                                                                       (T (IPLUS \KEYBOARDEVENT.SIZE
                                                                                 R]
                                                        (fetch (RING WRITE) of 
                                                                                  \KEYBOARDEVENTQUEUE
                                                               ))
                                                    (replace (RING READ) of 
                                                                                  \KEYBOARDEVENTQUEUE
                                                       with 0]
         (PROGN                                              (* ; "update dummy shift state")
                (replace DUMMY1SHIFT of \SHIFTSTATE with (fetch (KEYBOARDEVENT 1SHIFT
                                                                                       ) of
                                                                                         
                                                                                        \LASTKEYSTATE
                                                                            ))
                (replace DUMMY2SHIFT of \SHIFTSTATE with (fetch (KEYBOARDEVENT 2SHIFT
                                                                                       ) of
                                                                                         
                                                                                        \LASTKEYSTATE
                                                                            ))
                (replace DUMMYLOCK of \SHIFTSTATE with (fetch (KEYBOARDEVENT LOCK)
                                                                      of \LASTKEYSTATE))
                (replace DUMMYCTRL of \SHIFTSTATE with (fetch (KEYBOARDEVENT CTRL)
                                                                      of \LASTKEYSTATE))
                (replace DUMMYMETA of \SHIFTSTATE with (fetch (KEYBOARDEVENT META)
                                                                      of \LASTKEYSTATE))
                (replace DUMMYFONT of \SHIFTSTATE with (fetch (KEYBOARDEVENT FONT)
                                                                      of \LASTKEYSTATE))
                (replace DUMMYUSERMODE1 of \SHIFTSTATE with (fetch (KEYBOARDEVENT
                                                                                    USERMODE1)
                                                                           of \LASTKEYSTATE))
                (replace DUMMYUSERMODE2 of \SHIFTSTATE with (fetch (KEYBOARDEVENT
                                                                                    USERMODE2)
                                                                           of \LASTKEYSTATE))
                (replace DUMMYUSERMODE3 of \SHIFTSTATE with (fetch (KEYBOARDEVENT
                                                                                    USERMODE3)
                                                                           of \LASTKEYSTATE))
                (replace DUMMYALTGRAPH of \SHIFTSTATE with (fetch (KEYBOARDEVENT
                                                                                   ALTGRAPH)
                                                                          of \LASTKEYSTATE))
                (replace DUMMYDEADKEYPENDING of \SHIFTSTATE with (fetch (
                                                                                        KEYBOARDEVENT
                                                                                         
                                                                                       DEADKEYPENDING
                                                                                         )
                                                                                of \LASTKEYSTATE)
                       ))

         (* ;; "Note: there is a window between the test of READ above and the setting of \KEYBUFFERING below where a keyboard transition can be ignored until the next transition causes \KEYBUFFERING to be set again")

         (COND
            ((NOT (OR PENDINGINTERRUPT \PENDINGINTERRUPT))   (* ; 
                                     "No interrupt noticed this time or on any previous invocation")
             (SETQ \KEYBUFFERING NIL))
            ((NOT (\GETBASEPTR (\STKSCAN '\INTERRUPTABLE)
                         0))                                 (* ; 
                                                      "We're not interruptable, so try again later")
             (SETQ \PENDINGINTERRUPT T)
             (SETQ \KEYBUFFERING NIL))
            (T (SETQ \PENDINGINTERRUPT NIL)
               (SETQ \KEYBUFFERING NIL)
               (LET ((\INTERRUPTABLE T))
                    (INTERRUPTED])

(\TIMER.INTERRUPTFRAME
  [LAMBDA NIL                                            (* lmm "22-Apr-85 09:47")
                                                             (* place holder for periodic 
                                                           interrupts)
    (if NIL
        then (APPLY* \PERIODIC.INTERRUPT)
              (if \PERIODIC.INTERRUPT
                  then (SETUPTIMER (QUOTIENT (TIMES \PERIODIC.INTERRUPT.FREQUENCY \RCLKSECOND)
                                              77)
                                  (LOCF (fetch DLMOUSETIMER of \MISCSTATS))
                                  'TICKS)
                        (SETQ \TIMER.INTERRUPT.PENDING T])

(\PERIODIC.INTERRUPTFRAME
  [LAMBDA NIL
    (DECLARE (GLOBALVARS \PERIODIC.INTERRUPT))       (* lmm "16-Jul-85 16:22")
    (LET ((FN \PERIODIC.INTERRUPT))
         (AND FN (SPREADAPPLY* FN])
)

(RPAQ? \KEYBUFFERING )

(RPAQ? \PERIODIC.INTERRUPT )

(RPAQ? \TIMER.INTERRUPT.PENDING )

(RPAQ? \PERIODIC.INTERRUPT.FREQUENCY 77)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)



(* ; "cursor and mouse related functions.")

(DEFINEQ

(\HARDCURSORUP
  [LAMBDA (NEWCURSOR INVERTFLG)                       (* ; "Edited  2-Jan-2000 18:10 by kaplan")
                                                             (* ; 
   "version of \CURSORUP that knows about the possibility of the cursor being on the color screen.")
    (PROG (IMAGE)
          (SETQ \SOFTCURSORP NIL)
          (SETQ \CURRENTCURSOR NEWCURSOR)
          (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR))
          [COND
             ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)
                       (fetch (BITMAP BITMAPBITSPERPIXEL) of \CURSORDESTINATION)))
              (\CURSORBITSPERPIXEL NEWCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL) of 
                                                                                   \CURSORDESTINATION
                                                        ))
              (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR]
          (BITBLT IMAGE 0 0 CursorBitMap 0 (IDIFFERENCE HARDCURSORHEIGHT (fetch (BITMAP 
                                                                                         BITMAPHEIGHT
                                                                                           )
                                                                            of IMAGE))
                 HARDCURSORWIDTH HARDCURSORHEIGHT (COND
                                                     (INVERTFLG 'INVERT)
                                                     (T 'INPUT))
                 'REPLACE)
          (SELECTC \MACHINETYPE
              (\DAYBREAK (\DoveDisplay.SetCursorShape CursorBitMap))
              (\MAIKO (SUBRCALL DSPCURSOR (fetch (CURSOR CUHOTSPOTX) of NEWCURSOR)
                             (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR)))
              NIL])

(\HARDCURSORPOSITION
  [LAMBDA (XPOS YPOS)                                    (* kbr%: "13-Jun-85 21:24")
          (* sets cursor position, adjusts for hotspot and tty region limits.
        XPOS and YPOS are the screen coordinates of the hotspot location.)

    (DECLARE (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURSORDESTWIDTH \CURSORDESTHEIGHT))
          (* YPOS is reflected around CURSORYMAX because the screen has
        (0,0) as the upper left corner. *)

    (SETQ YPOS (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT)
                      YPOS))                                 (* Clip coordinates *)
    (SETQ XPOS (UNSIGNED (IDIFFERENCE (COND
                                         ((ILESSP XPOS 0)
                                          0)
                                         ((IGEQ XPOS \CURSORDESTWIDTH)
                                          (SUB1 \CURSORDESTWIDTH))
                                         (T XPOS))
                                \CURSORHOTSPOTX)
                      BITSPERWORD))
    (SETQ YPOS (UNSIGNED (IDIFFERENCE (COND
                                         ((ILESSP YPOS 0)
                                          0)
                                         ((IGEQ YPOS \CURSORDESTHEIGHT)
                                          (SUB1 \CURSORDESTHEIGHT))
                                         (T YPOS))
                                \CURSORHOTSPOTY)
                      BITSPERWORD))
    [COND
       ((EQ \MACHINETYPE \DANDELION)                         (* Temporary workaround)
        (COND
           ((IGREATERP YPOS 32767)
            (SETQ YPOS 0)))
        (COND
           ((IGREATERP XPOS 32767)
            (SETQ XPOS 0]
    (\SETMOUSEXY XPOS YPOS)
    (PROGN 
          (* change the cursor position too so that GETMOUSESTATE will get the correct 
        values if it is called before the next 60 cycle interrupt.)

           (\PUTBASE \EM.CURSORX 0 XPOS)
           (\PUTBASE \EM.CURSORY 0 YPOS))
    NIL])

(\HARDCURSORDOWN
  [LAMBDA NIL                                            (* kbr%: "23-Apr-85 18:26")
    (\CLEARBM (CURSORBITMAP])
)
(DEFINEQ

(CURSOR.INIT
  [LAMBDA NIL                                            (* kbr%: "23-Jan-86 17:34")
    (PROG (DESTBPL)                                          (* Assorted globals for doing the 
                                                           color cursor. *)
          (SETQ \CURSORDESTINATION ScreenBitMap)
          (SETQ \SOFTCURSORUPBM NIL)
          (SETQ \SOFTCURSORDOWNBM NIL)
          (SETQ \CURSORDESTLINE 0)
          (SETQ \CURSORDESTLINEBASE (fetch (BITMAP BITMAPBASE) of ScreenBitMap))
          (SETQ \CURSORDESTWIDTH (fetch (BITMAP BITMAPWIDTH) of ScreenBitMap))
          (SETQ \CURSORDESTHEIGHT (fetch (BITMAP BITMAPHEIGHT) of ScreenBitMap))
          (SETQ \CURSORDESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of ScreenBitMap))
                                                             (* Initialize PILOTBBTs.
                                                           *)
          (SETQ DESTBPL (UNFOLD \CURSORDESTRASTERWIDTH BITSPERWORD))
          (* These PILOTBBTs are the mixing areas for forming the color cursor image.
        *)
                                                             (* Does SCREEN to DOWNBM via INPUT, 
                                                           REPLACE. *)
          (SETQ \SOFTCURSORBBT1
           (create PILOTBBT
                  PBTSOURCEBPL _ DESTBPL
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 0))
          (\LOCKCELL \SOFTCURSORBBT1)                        (* Does DOWNBM to UPBM via INPUT, 
                                                           REPLACE. *)
          (SETQ \SOFTCURSORBBT2
           (create PILOTBBT
                  PBTDESTBIT _ 0
                  PBTSOURCEBIT _ 0
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 0))
          (\LOCKCELL \SOFTCURSORBBT2)                        (* Does MASK to UPBM via INPUT, 
                                                           ERASE. *)
          (SETQ \SOFTCURSORBBT3
           (create PILOTBBT
                  PBTDESTBIT _ 0
                  PBTSOURCEBIT _ 0
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 1
                  PBTOPERATION _ 1))
          (\LOCKCELL \SOFTCURSORBBT3)                        (* Does IMAGE to UPBM via INPUT, 
                                                           PAINT. *)
          (SETQ \SOFTCURSORBBT4
           (create PILOTBBT
                  PBTDESTBIT _ 0
                  PBTSOURCEBIT _ 0
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 2))
          (\LOCKCELL \SOFTCURSORBBT4)                        (* Does UPBM to SCREEN via INPUT, 
                                                           REPLACE. *)
          (SETQ \SOFTCURSORBBT5
           (create PILOTBBT
                  PBTDESTBPL _ DESTBPL
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 0))
          (\LOCKCELL \SOFTCURSORBBT5)                        (* Does DOWNBM to SCREEN via INPUT, 
                                                           REPLACE. *)
          (SETQ \SOFTCURSORBBT6
           (create PILOTBBT
                  PBTDESTBPL _ DESTBPL
                  PBTDISJOINT _ T
                  PBTSOURCETYPE _ 0
                  PBTOPERATION _ 0))
          (\LOCKCELL \SOFTCURSORBBT6)                        (* Lock things down.
                                                           *)
      ])

(\CURSORDESTINATION
  [LAMBDA (DESTINATION)                                  (* kbr%: " 2-Sep-85 20:13")
                                                             (* Change DESTINATION of 
                                                           \CURRENTCURSOR, assuming it is down.
                                                           *)
    (PROG (DESTBPL)
          (COND
             ((NOT (EQ DESTINATION \CURSORDESTINATION))
              (UNINTERRUPTABLY
                  [COND
                     ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CURSOR
                                                                                         CUIMAGE)
                                                                                of \CURRENTCURSOR
                                                                                    ))
                               (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION)))
                      (\CURSORBITSPERPIXEL \CURRENTCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL)
                                                                 of DESTINATION]
                  (\SETMOUSEXY 0 0)
                  (\PUTBASE \EM.CURSORX 0 0)
                  (\PUTBASE \EM.CURSORY 0 0)
                  (SETQ \CURSORDESTLINE 0)
                  (SETQ.NOREF \CURSORDESTLINEBASE (fetch (BITMAP BITMAPBASE) of DESTINATION))
                  (SETQ \CURSORDESTWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION))
                  (SETQ \CURSORDESTHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTINATION))
                  (SETQ \CURSORDESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of 
                                                                                          DESTINATION
                                                      ))
                  (SETQ DESTBPL (UNFOLD \CURSORDESTRASTERWIDTH BITSPERWORD))
                  (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT1 with DESTBPL)
                  (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT5 with DESTBPL)
                  (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT6 with DESTBPL)
                  (SETQ \CURSORDESTINATION DESTINATION))])

(\SOFTCURSORUP
  [LAMBDA (NEWCURSOR)                                    (* kbr%: " 2-Sep-85 20:15")
          (* Put soft NEWCURSOR up, assuming soft cursor is down.
        *)

    (PROG (IMAGE MASK WIDTH BWIDTH HEIGHT CURSORBITSPERPIXEL CURSORBPL UPBMBASE DOWNBMBASE)
                                                             (* Get cursor IMAGE & MASK.
                                                           *)
          (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR))
          (SETQ MASK (fetch (CURSOR CUMASK) of NEWCURSOR))
          (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of IMAGE))
          (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of IMAGE))
          (SETQ CURSORBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE))
                                                             (* Create new UPBM & DOWNBM caches 
                                                           if necessary. *)
          (COND
             ((NOT (AND (type? BITMAP \SOFTCURSORUPBM)
                        (EQ (fetch (BITMAP BITMAPWIDTH) of \SOFTCURSORUPBM)
                            WIDTH)
                        (EQ (fetch (BITMAP BITMAPHEIGHT) of \SOFTCURSORUPBM)
                            HEIGHT)
                        (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of \SOFTCURSORUPBM)
                            CURSORBITSPERPIXEL)))
              (SETQ \SOFTCURSORWIDTH WIDTH)
              (SETQ \SOFTCURSORHEIGHT HEIGHT)
              (SETQ \SOFTCURSORUPBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL))
              (SETQ \SOFTCURSORDOWNBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL))
              (SETQ UPBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM))
              (\TEMPLOCKPAGES UPBMBASE 1)
              (SETQ DOWNBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM))
              (\TEMPLOCKPAGES DOWNBMBASE 1)
              (SETQ CURSORBPL (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH) of IMAGE)
                                     BITSPERWORD))
              (SETQ BWIDTH (ITIMES (fetch (BITMAP BITMAPWIDTH) of IMAGE)
                                  (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)))
              (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT1 with CURSORBPL)
              (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT2 with UPBMBASE)
              (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT2 with CURSORBPL)
              (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT2 with DOWNBMBASE)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT2 with CURSORBPL)
              (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT2 with BWIDTH)
              (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT2 with HEIGHT)
              (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT3 with UPBMBASE)
              (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT3 with CURSORBPL)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT3 with CURSORBPL)
              (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT3 with BWIDTH)
              (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT3 with HEIGHT)
              (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT4 with UPBMBASE)
              (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT4 with CURSORBPL)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT4 with CURSORBPL)
              (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT4 with BWIDTH)
              (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT4 with HEIGHT)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT5 with CURSORBPL)
              (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT6 with CURSORBPL)))
                                                             (* Change PILOTBBTs.
                                                           *)
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT3 with (fetch (BITMAP 
                                                                                           BITMAPBASE
                                                                                              )
                                                                               of MASK))
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT4 with (fetch (BITMAP 
                                                                                           BITMAPBASE
                                                                                              )
                                                                               of IMAGE))
                                                             (* Put up new \CURRENTCURSOR.
                                                           *)
          (SETQ \CURRENTCURSOR NEWCURSOR)
          (\TEMPLOCKPAGES \CURRENTCURSOR 1)
          (SETQ \SOFTCURSORP T)
          (\SOFTCURSORUPCURRENT])

(\SOFTCURSORUPCURRENT
  [LAMBDA NIL                                            (* kbr%: "18-Aug-85 15:09")
          (* Put soft \CURRENTCURSOR up, assuming soft cursor is down.
        *)

    (PROG (DISPINTERRUPT X Y XBASE YBASE WIDTH HEIGHT BITSPERPIXEL MINUSDESTRASTERWIDTH DEST DESTBIT 
                 SOURCEOFFSET UPBMSOURCE DOWNBMSOURCE SOURCEBIT)
          (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))
          (\PUTBASE \EM.DISPINTERRUPT 0 0)
          (SETQ \SOFTCURSORUPP T)                            (* Roughly, we want to
                                                           (BITBLT CURSOR XBASE YBASE SCREEN X 
                                                           Y WIDTH HEIGHT) *)
          (SETQ X (SIGNED (\GETBASE \EM.MOUSEX 0)
                         BITSPERWORD))
          (SETQ Y (SIGNED (\GETBASE \EM.MOUSEY 0)
                         BITSPERWORD))
          (SETQ XBASE 0)
          (SETQ YBASE 0)
          (SETQ WIDTH \SOFTCURSORWIDTH)
          (SETQ HEIGHT \SOFTCURSORHEIGHT)                    (* Clip off screen parts of cursor.
                                                           *)
          [COND
             ((IGREATERP 0 X)                                (* Some of cursor is to left of 
                                                           screen. *)
              (SETQ XBASE (IMINUS X))
              (SETQ WIDTH (IDIFFERENCE WIDTH XBASE))
              (SETQ X 0))
             ((IGREATERP (IPLUS X WIDTH)
                     \CURSORDESTWIDTH)                       (* Some of cursor is to right of 
                                                           screen. *)
              (SETQ WIDTH (IDIFFERENCE \CURSORDESTWIDTH X]
          (COND
             ((ILESSP WIDTH 0)
              (GO EXIT)))
          [COND
             ((IGREATERP 0 Y)                                (* Some of cursor is to above of 
                                                           screen. *)
              (SETQ YBASE (IMINUS Y))
              (SETQ HEIGHT (IDIFFERENCE HEIGHT YBASE))
              (SETQ Y 0))
             ((IGREATERP (IPLUS Y HEIGHT)
                     \CURSORDESTHEIGHT)                      (* Some of cursor is to below of 
                                                           screen. *)
              (SETQ HEIGHT (IDIFFERENCE \CURSORDESTHEIGHT Y]
          (COND
             ((ILESSP HEIGHT 0)
              (GO EXIT)))
          (* These loops reset \CURSORDESTLINEBASE while avoiding large number 
        arithmetic. *)

          [COND
             [(IGREATERP \CURSORDESTLINE Y)
              (SETQ MINUSDESTRASTERWIDTH (IMINUS \CURSORDESTRASTERWIDTH))
              (until (EQ \CURSORDESTLINE Y) do (SETQ \CURSORDESTLINE (SUB1 \CURSORDESTLINE))
                                                      (SETQ.NOREF \CURSORDESTLINEBASE
                                                             (\ADDBASE \CURSORDESTLINEBASE 
                                                                    MINUSDESTRASTERWIDTH]
             ((ILESSP \CURSORDESTLINE Y)
              (until (EQ \CURSORDESTLINE Y) do (SETQ \CURSORDESTLINE (ADD1 \CURSORDESTLINE))
                                                      (SETQ.NOREF \CURSORDESTLINEBASE
                                                             (\ADDBASE \CURSORDESTLINEBASE 
                                                                    \CURSORDESTRASTERWIDTH]
                                                             (* Reset PILOTBBTs.
                                                           *)
          (SETQ BITSPERPIXEL (fetch (CURSOR CUBITSPERPIXEL) of \CURRENTCURSOR))
          (SETQ X (ITIMES BITSPERPIXEL X))
          (SETQ XBASE (ITIMES BITSPERPIXEL XBASE))
          (SETQ WIDTH (ITIMES BITSPERPIXEL WIDTH))
          (SETQ DEST \CURSORDESTLINEBASE)
          (SETQ DESTBIT X)
          (SETQ SOURCEOFFSET (ITIMES YBASE (fetch (BITMAP BITMAPRASTERWIDTH) of 
                                                                                      \SOFTCURSORUPBM
                                                  )))
          (SETQ UPBMSOURCE (\ADDBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM)
                                  SOURCEOFFSET))
          (SETQ DOWNBMSOURCE (\ADDBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM)
                                    SOURCEOFFSET))
          (SETQ SOURCEBIT XBASE)
          (* TBW%: Most of these fields only need to be set if we are clipping this 
        time or the previous time we put the cursor up.
        *)

          (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT1 with DOWNBMSOURCE)
          (replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT1 with SOURCEBIT)
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT1 with DEST)
          (replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT1 with DESTBIT)
          (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT1 with WIDTH)
          (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT1 with HEIGHT)
          (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT5 with DEST)
          (replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT5 with DESTBIT)
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT5 with UPBMSOURCE)
          (replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT5 with SOURCEBIT)
          (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT5 with WIDTH)
          (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT5 with HEIGHT)
          (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT6 with DEST)
          (replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT6 with DESTBIT)
          (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT6 with DOWNBMSOURCE)
          (replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT6 with SOURCEBIT)
          (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT6 with WIDTH)
          (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT6 with HEIGHT)
                                                             (* Save background behind cursor.
                                                           *)
          (\PILOTBITBLT \SOFTCURSORBBT1 0)                   (* Compute cursor appearance.
                                                           UPBM = (OR IMAGE (AND DOWNBM
                                                           (NOT MASK))) *)
          (\PILOTBITBLT \SOFTCURSORBBT2 0)
          (\PILOTBITBLT \SOFTCURSORBBT3 0)
          (\PILOTBITBLT \SOFTCURSORBBT4 0)                   (* Put color cursor up.
                                                           *)
          (\SOFTCURSORPILOTBITBLT \SOFTCURSORBBT5 0)
      EXIT
          (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT])

(\SOFTCURSORPOSITION
  [LAMBDA (X Y)                                          (* kbr%: "18-Aug-85 14:50")
                                                             (* Move soft cursor.
                                                           *)
    (PROG (DISPINTERRUPT)
          (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))
          (\PUTBASE \EM.DISPINTERRUPT 0 0)
          [COND
             ((OR (NOT (EQ (\GETBASE \EM.CURSORX 0)
                           X))
                  (NOT (EQ (\GETBASE \EM.CURSORY 0)
                           Y)))
              (COND
                 (\SOFTCURSORUPP (\SOFTCURSORDOWN)
                        (\SOFTCURSORUPCURRENT]
          (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT])

(\SOFTCURSORDOWN
  [LAMBDA NIL                                            (* kbr%: " 6-Jul-85 00:09")
                                                             (* Take COLOR cursor down.
                                                           *)
    (PROG (DISPINTERRUPT)                                    (* \SOFTCURSORUPP must be set to NIL 
                                                           before BITBLTing. *)
          (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0))
          (\PUTBASE \EM.DISPINTERRUPT 0 0)
          (SETQ \SOFTCURSORUPP NIL)
          (\SOFTCURSORPILOTBITBLT \SOFTCURSORBBT6 0)
          (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT])

(CURSORPROP
  [LAMBDA X                                              (* kbr%: "11-Jan-86 20:03")
    (COND
       ((IGREATERP X 2)
        (PUTCURSORPROP (ARG X 1)
               (ARG X 2)
               (ARG X 3)))
       ((EQ X 2)
        (GETCURSORPROP (ARG X 1)
               (ARG X 2)))
       (T (\ILLEGAL.ARG NIL])

(GETCURSORPROP
  [LAMBDA (CURSOR PROP)                              (* kbr%: "26-Apr-85 11:18")
    (LISTGET (fetch (CURSOR CUDATA) of CURSOR)
           PROP])

(PUTCURSORPROP
  [LAMBDA (CURSOR PROP VALUE)                        (* kbr%: "26-Apr-85 11:18")
    (PROG (OLDDATA OLDVALUE)
          (SETQ OLDDATA (fetch (CURSOR CUDATA) of CURSOR))
          [COND
             [OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP))
                    (COND
                       (VALUE (LISTPUT OLDDATA PROP VALUE))
                       (OLDVALUE (COND
                                    [(EQ (CAR OLDDATA)
                                         PROP)
                                     (replace (CURSOR CUDATA) of CURSOR
                                        with (CDDR (fetch (CURSOR CUDATA) of CURSOR]
                                    (T (FOR TAIL ON (CDR OLDDATA) BY (CDDR TAIL)
                                          WHEN (EQ (CADR TAIL)
                                                       PROP) DO (FRPLACD TAIL (CDDDR TAIL))
                                                                   (RETURN]
             (VALUE (replace (CURSOR CUDATA) of CURSOR with (LIST PROP VALUE]
          (RETURN OLDVALUE])

(\CURSORBITSPERPIXEL
  [LAMBDA (CURSOR NEWBITSPERPIXEL)                   (* kbr%: "12-May-85 17:15")
          (* Swap in NEWBITSPERPIXEL IMAGE and MASK, creating them if necessary.
        *)

    (PROG (OLDBITSPERPIXEL OLDIMAGE OLDMASK WHITE BLACK NEWIMAGE NEWMASK)
          (SETQ OLDBITSPERPIXEL (fetch (CURSOR CUBITSPERPIXEL) of CURSOR))
          (COND
             ((EQ OLDBITSPERPIXEL NEWBITSPERPIXEL)
              (RETURN)))                                     (* Save OLDIMAGE and OLDMASK.
                                                           *)
          (SETQ OLDIMAGE (fetch (CURSOR CUIMAGE) of CURSOR))
          (SETQ OLDMASK (fetch (CURSOR CUMASK) of CURSOR))
          (CURSORPROP CURSOR (\CURSORIMAGEPROPNAME OLDBITSPERPIXEL)
                 OLDIMAGE)
          (CURSORPROP CURSOR (\CURSORMASKPROPNAME OLDBITSPERPIXEL)
                 OLDMASK)
          (* Unsave NEWIMAGE and NEWMASK if possible, otherwise create them.
        *)

          [COND
             [(SETQ NEWIMAGE (CURSORPROP CURSOR (\CURSORIMAGEPROPNAME NEWBITSPERPIXEL)))
                                                             (* Use cached NEWIMAGE & NEWMASK.
                                                           *)
              (SETQ NEWMASK (CURSORPROP CURSOR (\CURSORMASKPROPNAME NEWBITSPERPIXEL]
             (T                                              (* Create NEWIMAGE & NEWMASK.
                                                           *)
                (SETQ WHITE (MASK.1'S 0 NEWBITSPERPIXEL))
                (SETQ BLACK 0)
                (SETQ NEWIMAGE (COLORIZEBITMAP (CURSORPROP CURSOR 'IMAGE1)
                                      BLACK WHITE NEWBITSPERPIXEL))
                (SETQ NEWMASK (COLORIZEBITMAP (CURSORPROP CURSOR 'MASK1)
                                     BLACK WHITE NEWBITSPERPIXEL]
          (replace (CURSOR CUIMAGE) of CURSOR with NEWIMAGE)
          (replace (CURSOR CUMASK) of CURSOR with NEWMASK])

(\CURSORIMAGEPROPNAME
  [LAMBDA (BITSPERPIXEL)                                 (* kbr%: "26-Apr-85 11:18")
    (SELECTQ BITSPERPIXEL
        (1 'IMAGE1)
        (4 'IMAGE4)
        (8 'IMAGE8)
        (SHOULDNT])

(\CURSORMASKPROPNAME
  [LAMBDA (BITSPERPIXEL)                                 (* kbr%: "26-Apr-85 11:18")
    (SELECTQ BITSPERPIXEL
        (1 'MASK1)
        (4 'MASK4)
        (8 'MASK8)
        (SHOULDNT])
)
(DEFINEQ

(CURSORCREATE
  [LAMBDA (IMAGE MASK HOTSPOTX HOTSPOTY DATA)            (* ; "Edited 10-Jul-92 16:32 by cat")
                                                             (* ; "Edited 31-Jul-87 10:01 by jds")

    (* ;; "creates a cursor from a bitmap.  HOTSPOTX and HOTSPOTY specify the hotspot.")

    (* ;; "INVARIANTS:  the hot spot X and Y must be in the range 0..(width - 1) and 0..(height - 1), respectively.")

    (PROG (CURSOR)
          (COND
             ((OR (FIXP MASK)
                  (POSITIONP MASK))

              (* ;; "If Mask is a fixp then we presume this is the old arg list (bitmap x y).  the cursor filepkgtype has been changed to write the new arg list.  The other is provided for (dubious) compatibility")

              (SETQ HOTSPOTY HOTSPOTX)
              (SETQ HOTSPOTX MASK)
              (SETQ MASK NIL)))

     (* ;; "Make sure that the image and mask bitmaps are no larger than the hardware cursor, i.e. 16x16 bits [AR 8916 7/31/87]:")

          (COND
             ((OR (IGREATERP (BITMAPWIDTH IMAGE)
                         16)
                  (IGREATERP (BITMAPHEIGHT IMAGE)
                         16))                                (* ; "IMAGE is too big.")
              (\ILLEGAL.ARG IMAGE))
             ((NOT MASK)                                     (* ; "No mask, so it's OK")
              )
             ((OR (IGREATERP (BITMAPWIDTH MASK)
                         16)
                  (IGREATERP (BITMAPHEIGHT MASK)
                         16))                                (* ; "MASK is too big.")
              (\ILLEGAL.ARG MASK)))
          [COND
             ((POSITIONP HOTSPOTX)

              (* ;; 
            "The hot spot can be specified as a position in one arg, rather than X and Y in two:")

              (SETQ HOTSPOTY (fetch (POSITION YCOORD) of HOTSPOTX))
              (SETQ HOTSPOTX (fetch (POSITION XCOORD) of HOTSPOTX]
          (SETQ CURSOR (create CURSOR
                              CUIMAGE _ IMAGE
                              CUMASK _ (OR MASK IMAGE)
                              CUHOTSPOTX _ (IMAX 0 (IMIN (SUB1 (BITMAPWIDTH IMAGE))
                                                         (OR (FIXP HOTSPOTX)
                                                             0)))
                              CUHOTSPOTY _ [IMAX 0 (IMIN (SUB1 (BITMAPHEIGHT IMAGE))
                                                         (OR (FIXP HOTSPOTY)
                                                             (SUB1 (BITMAPHEIGHT IMAGE]
                              CUDATA _ DATA))
          (RETURN CURSOR])

(CURSOR
  [LAMBDA (NEWCURSOR INVERTFLG)                          (* ; "Edited 24-Mar-87 18:30 by jds")

    (* ;; "Installs NEWCURSOR as the cursor and returns the old cursor state.  If INVERTFLG is non-NIL, the cursor image is inverted during installation.  If NEWCURSOR is NIL, just returns the current cursor state.")

    (DECLARE (GLOBALVARS DEFAULTCURSOR \SOFTCURSORP))
    (PROG (OLDCURSOR)
          (SETQ OLDCURSOR \CURRENTCURSOR)
          (COND
             ((EQ NEWCURSOR T)                               (* ; 
                                                "If NEWCURSOR is T, use the system default cursor.")

              (SETQ NEWCURSOR DEFAULTCURSOR)))
          (COND
             [(\CURSOR-VALID-P NEWCURSOR \SOFTCURSORP)   (* ; 
                                               "Only install the cursor if it's a real, valid one.")

              (\CURSORDOWN)
              (\CURSORUP NEWCURSOR INVERTFLG)            (* ; 
                         "set after adjustment to avoid confusion about hotspot during adjustment.")

              (SETQ \CURSORHOTSPOTX (fetch (CURSOR CUHOTSPOTX) of NEWCURSOR))
              (SETQ \CURSORHOTSPOTY (IDIFFERENCE (SUB1 (fetch (BITMAP BITMAPHEIGHT)
                                                          of (fetch (CURSOR CUIMAGE)
                                                                    of NEWCURSOR)))
                                           (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR]
             (NEWCURSOR                                      (* ; "NEWCURSOR = NIL means just return the old one, so only error if one got specified that wasn't valid.")

                    (\ILLEGAL.ARG NEWCURSOR)))
          (RETURN OLDCURSOR])

(\CURSOR-VALID-P
  [LAMBDA (CURSOR SOFT?)                             (* ; "Edited 25-Mar-87 09:41 by jds")

    (* ;; "It returns T if CURSOR is a valid cursor.  Validity depends on whether it's meant to be displayed using the cursor hardware or the cursor software.")

    (* ;; "This is really wed to the D-machine display architecture. ")

    (AND (CURSORP CURSOR)
         (COND
            (SOFT? T)
            (T (LET ((IMAGE (fetch (CURSOR CUIMAGE) of CURSOR))
                     (HOTSPOT-X (fetch (CURSOR CUHOTSPOTX) of CURSOR))
                     (HOTSPOT-Y (fetch (CURSOR CUHOTSPOTY) of CURSOR)))
                    (* ;; "The bitmap must be <= 16x16, and the hot spot must be within the cursor if we're using hardware cursor.")

                    (AND (>= 16 (BITMAPWIDTH IMAGE))
                         (>= 16 (BITMAPHEIGHT IMAGE))
                         (<= 0 HOTSPOT-X)
                         (< HOTSPOT-X 16)
                         (<= 0 HOTSPOT-Y)
                         (< HOTSPOT-Y 16])

(\CURSORUP
  [LAMBDA (NEWCURSOR INVERTFLG)                          (* kbr%: "18-Aug-85 14:38")
    (UNINTERRUPTABLY
        (\CURSORBITSPERPIXEL NEWCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL) of 
                                                                                   \CURSORDESTINATION
                                                  ))
        (COND
           ((AND (EQ (fetch (CURSOR CUIMAGE) of NEWCURSOR)
                     (fetch (CURSOR CUMASK) of NEWCURSOR))
                 (ILEQ (fetch (BITMAP BITMAPWIDTH) of (fetch (CURSOR CUIMAGE)
                                                                 of NEWCURSOR))
                       HARDCURSORWIDTH)
                 (ILEQ (fetch (BITMAP BITMAPHEIGHT) of (fetch (CURSOR CUIMAGE)
                                                                  of NEWCURSOR))
                       HARDCURSORHEIGHT)
                 (EQ \CURSORDESTINATION ScreenBitMap))
            (\HARDCURSORUP NEWCURSOR INVERTFLG))
           (T (\SOFTCURSORUP NEWCURSOR)))
        (ADJUSTCURSORPOSITION (IDIFFERENCE \CURSORHOTSPOTX (fetch (CURSOR CUHOTSPOTX)
                                                                  of NEWCURSOR))
               (IDIFFERENCE (IDIFFERENCE (SUB1 (fetch (BITMAP BITMAPHEIGHT)
                                                  of (fetch (CURSOR CUIMAGE) of
                                                                                         NEWCURSOR)))
                                   (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR))
                      \CURSORHOTSPOTY)))])

(\CURSORPOSITION
  [LAMBDA (XPOS YPOS)                                    (* ; "Edited 19-Mar-98 14:41 by jds")

         (* sets cursor position, adjusts for hotspot and tty region limits.
       XPOS and YPOS are the screen coordinates of the hotspot location.)

    (DECLARE (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURSORDESTWIDTH \CURSORDESTHEIGHT))

         (* YPOS is reflected around CURSORYMAX because the screen has
       (0,0) as the upper left corner. *)

    (SETQ YPOS (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT)
                      YPOS))                                 (* Clip coordinates *)
    (SETQ XPOS (UNSIGNED (IDIFFERENCE (COND
                                         (NIL 
                                              (* ;; "Removed 2000/1/3 JDS so mousr cursors work.")

                                              (ILESSP XPOS 0)
                                              0)
                                         ((IGEQ XPOS \CURSORDESTWIDTH)
                                          (SUB1 \CURSORDESTWIDTH))
                                         (T XPOS))
                                \CURSORHOTSPOTX)
                      BITSPERWORD))
    (SETQ YPOS (UNSIGNED (IDIFFERENCE (COND
                                         (NIL (ILESSP YPOS 0)
                                              0)
                                         ((IGEQ YPOS \CURSORDESTHEIGHT)
                                          (SUB1 \CURSORDESTHEIGHT))
                                         (T YPOS))
                                \CURSORHOTSPOTY)
                      BITSPERWORD))
    [COND
       ((EQ \MACHINETYPE \DANDELION)                         (* Temporary workaround)
        (COND
           ((IGREATERP YPOS 32767)
            (SETQ YPOS 0)))
        (COND
           ((IGREATERP XPOS 32767)
            (SETQ XPOS 0]
    (\SETMOUSEXY XPOS YPOS)
    (COND
       (\SOFTCURSORP (\SOFTCURSORPOSITION XPOS YPOS)))
    [PROGN 

         (* change the cursor position too so that GETMOUSESTATE will get the correct 
       values if it is called before the next 60 cycle interrupt.)

           (\PUTBASE \EM.CURSORX 0 XPOS)
           (\PUTBASE \EM.CURSORY 0 YPOS)
           (COND
              ((EQ \MACHINETYPE \DAYBREAK)                   (* Need to notify DAYBREAK IOP to 
                                                           move cursor. *)
               (\DoveDisplay.SetCursorPosition XPOS YPOS]
    NIL])

(\CURSORDOWN
  [LAMBDA NIL                                            (* kbr%: "12-Jun-85 17:21")
    (UNINTERRUPTABLY
        (COND
           (\SOFTCURSORP (\SOFTCURSORDOWN))
           (T (\HARDCURSORDOWN))))])

(ADJUSTCURSORPOSITION
  [LAMBDA (DELTAX DELTAY)                                (* kbr%: " 6-Jan-86 11:55")
    (COND
       [(POSITIONP DELTAX)
        (\CURSORPOSITION (IPLUS (fetch (POSITION XCOORD) of DELTAX)
                                    (\XMOUSECOORD))
               (IPLUS (fetch (POSITION YCOORD) of DELTAX)
                      (\YMOUSECOORD]
       (T (\CURSORPOSITION (IPLUS (OR DELTAX 0)
                                      (\XMOUSECOORD))
                 (IPLUS (OR DELTAY 0)
                        (\YMOUSECOORD])

(CURSORPOSITION
  [LAMBDA (NEWPOSITION DISPLAYSTREAM OLDPOSITION)        (* kbr%: "13-Feb-86 15:53")
    (PROG (DD)
          (SETQ DD (\GETDISPLAYDATA DISPLAYSTREAM))
          (OR (type? POSITION OLDPOSITION)
              (SETQ OLDPOSITION (create POSITION)))
          (freplace (POSITION XCOORD) of OLDPOSITION with (\DSPUNTRANSFORMX (\XMOUSECOORD
                                                                                         )
                                                                             DD))
          (freplace (POSITION YCOORD) of OLDPOSITION with (\DSPUNTRANSFORMY (\YMOUSECOORD
                                                                                         )
                                                                             DD))
          (COND
             ((type? POSITION NEWPOSITION)
              (\CURSORPOSITION (\DSPTRANSFORMX (fetch (POSITION XCOORD) of NEWPOSITION)
                                          DD)
                     (\DSPTRANSFORMY (fetch (POSITION YCOORD) of NEWPOSITION)
                            DD)))
             ((type? SCREENPOSITION NEWPOSITION)
              (CURSORSCREEN (fetch (SCREENPOSITION SCREEN) of NEWPOSITION)
                     (fetch (SCREENPOSITION XCOORD) of NEWPOSITION)
                     (fetch (SCREENPOSITION YCOORD) of NEWPOSITION)))
             (NEWPOSITION (\ILLEGAL.ARG NEWPOSITION)))
          (RETURN OLDPOSITION])

(CURSORSCREEN
  [LAMBDA (SCREEN XCOORD YCOORD)                         (* gbn%: "25-Jan-86 16:53")
          (* * sets up SCREEN to be the current screen, XCOORD %, YCOORD is initial pos 
        of cursor on SCREEN)

    (COND
       ((NULL XCOORD)
        (SETQ XCOORD 0)))
    (COND
       ((NULL YCOORD)
        (SETQ YCOORD 0)))
    (PROG (DESTINATION)
          (SETQ DESTINATION (fetch (SCREEN SCDESTINATION) of SCREEN))
          (\CURSORDOWN)
          (SETQ \CURSORSCREEN SCREEN)
          (\CURSORDESTINATION DESTINATION)
          (\CURSORUP \CURRENTCURSOR)
          (\CURSORPOSITION XCOORD YCOORD])

(CURSOREXIT
  [LAMBDA NIL                                            (* gbn%: "25-Jan-86 16:52")
          (* * called when cursor moves off the screen edge)

    (DECLARE (GLOBALVARS LASTSCREEN LASTMOUSEX LASTMOUSEY))
    (PROG (SCREEN XCOORD YCOORD SCREEN2 XCOORD2 YCOORD2)
          (SETQ SCREEN LASTSCREEN)
          (SETQ XCOORD LASTMOUSEX)
          (SETQ YCOORD LASTMOUSEY)
          (SETQ SCREEN2 (COND
                           ((EQ SCREEN \MAINSCREEN)
                            \COLORSCREEN)
                           (T \MAINSCREEN)))                 (* generalize for more than two 
                                                           screens (or alternate physical 
                                                           arrangement of screens.))
          (COND
             ((EQ XCOORD 0)
              (SETQ XCOORD2 (IDIFFERENCE (fetch (SCREEN SCWIDTH) of SCREEN2)
                                   2)))
             ((EQ XCOORD (SUB1 (fetch (SCREEN SCWIDTH) of SCREEN)))
              (SETQ XCOORD2 1))
             (T (RETURN)))
          [SETQ YCOORD2 (IQUOTIENT (ITIMES YCOORD (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN2))
                                          )
                               (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN]
          (CURSORSCREEN SCREEN2 XCOORD2 YCOORD2])

(FLIPCURSOR
-  [LAMBDA NIL                                         (* ; "Edited 24-Apr-88 00:04 by MASINTER")
-    (PROG (ADDR)
-          (COND
-             ((NOT \SOFTCURSORP)
-              (SETQ ADDR \EM.CURSORBITMAP)
-              (FRPTQ HARDCURSORHEIGHT [\PUTBASE ADDR 0 (LOGXOR (\GETBASE ADDR 0)
-                                                              (CONSTANT (SUB1 (EXPT 2 HARDCURSORWIDTH
-                                                                                    ]
-                     (SETQ ADDR (\ADDBASE ADDR 1)))
-              (SELECTC \MACHINETYPE
-                  (\DAYBREAK (\DoveDisplay.SetCursorShape))
-                  (\MAIKO (AND \CURRENTCURSOR (SUBRCALL DSPCURSOR (fetch (CURSOR CUHOTSPOTX)
-                                                                     of \CURRENTCURSOR)
-                                                     (fetch (CURSOR CUHOTSPOTY) of 
-                                                                                       \CURRENTCURSOR
-                                                            ))))
-                  NIL])

(FLIPCURSORBAR
-  [LAMBDA (N)                                            (* ; "Edited 19-Mar-98 14:23 by jds")
-
-(* ;;; "Inverts the Nth line of the cursor, N = 0 being the top")
-
-    (COND
-       ((NOT \SOFTCURSORP)
-        (\PUTBASE \EM.CURSORBITMAP N (LOGXOR (\GETBASE \EM.CURSORBITMAP N)
-                                            MAX.SMALLP))
-        (SELECTC \MACHINETYPE
-            (\DAYBREAK                                       (* ; "Notify IOP")
-                       (\DoveDisplay.SetCursorShape))
-            (\MAIKO (AND \CURRENTCURSOR (SUBRCALL DSPCURSOR (fetch (CURSOR CUHOTSPOTX)
-                                                               of \CURRENTCURSOR)
-                                               (fetch (CURSOR CUHOTSPOTY) of 
-                                                                                       \CURRENTCURSOR
-                                                      ))))
-            NIL])

(LASTMOUSEX
  [LAMBDA (DS)                                           (* rmk%: "30-AUG-83 13:07")
          (* returns the mouse x position in the coordinates of the DisplayStream DS)

    (\DSPUNTRANSFORMX LASTMOUSEX (\GETDISPLAYDATA DS])

(LASTMOUSEY
  [LAMBDA (DS)                                           (* rmk%: "30-AUG-83 13:07")
          (* returns the mouse y position in the coordinates of the DisplayStream DS)

    (\DSPUNTRANSFORMY LASTMOUSEY (\GETDISPLAYDATA DS])

(CREATEPOSITION
  [LAMBDA (XCOORD YCOORD)                                (* rmk%: " 6-Aug-84 13:43")
    (create POSITION
           XCOORD _ (OR XCOORD 0)
           YCOORD _ (OR YCOORD 0])

(POSITIONP
  [LAMBDA (X)                                            (* rrb "25-AUG-82 11:04")
          (* is X a position? For now just a cons check but should be made a datatype.)

    (AND (LISTP X)
         (NUMBERP (CAR X))
         (NUMBERP (CDR X))
         X])

(CURSORHOTSPOT
  [LAMBDA (NEWPOSITION)                                  (* gbn%: "26-Jan-86 15:36")
          (* returns the current cursor hot spot and sets the hot spot to NEWPOSITON if 
        one is given.)

    (PROG1 (create POSITION
                  XCOORD _ \CURSORHOTSPOTX
                  YCOORD _ \CURSORHOTSPOTY)
           (COND
              ((POSITIONP NEWPOSITION)
               (SETQ \CURSORHOTSPOTX (fetch (POSITION YCOORD) of NEWPOSITION))
               (SETQ \CURSORHOTSPOTY (fetch (POSITION YCOORD) of NEWPOSITION])
)

(PUTPROPS CURSORPROP ARGNAMES (NIL (CURSOR PROP {NEWVALUE}) . U))

(RPAQ? \CURSORHOTSPOTX 0)

(RPAQ? \CURSORHOTSPOTY 0)

(RPAQ? \CURRENTCURSOR NIL)

(RPAQ? \SOFTCURSORWIDTH NIL)

(RPAQ? \SOFTCURSORHEIGHT NIL)

(RPAQ? \SOFTCURSORP NIL)

(RPAQ? \SOFTCURSORUPP NIL)

(RPAQ? \SOFTCURSORUPBM NIL)

(RPAQ? \SOFTCURSORDOWNBM NIL)

(RPAQ? \SOFTCURSORBBT1 NIL)

(RPAQ? \SOFTCURSORBBT2 NIL)

(RPAQ? \SOFTCURSORBBT3 NIL)

(RPAQ? \SOFTCURSORBBT4 NIL)

(RPAQ? \SOFTCURSORBBT5 NIL)

(RPAQ? \SOFTCURSORBBT6 NIL)

(RPAQ? \CURSORSCREEN NIL)

(RPAQ? \CURSORDESTINATION NIL)

(RPAQ? \CURSORDESTHEIGHT 808)

(RPAQ? \CURSORDESTWIDTH 1024)

(RPAQ? \CURSORDESTRASTERWIDTH 64)

(RPAQ? \CURSORDESTLINE 0)

(RPAQ? \CURSORDESTLINEBASE NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH \SOFTCURSORHEIGHT 
       \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2
       \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 \CURSORDESTINATION 
       \CURSORDESTHEIGHT \CURSORDESTWIDTH \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE)
)
(DEFINEQ

(GETMOUSESTATE
  [LAMBDA NIL                                            (* kbr%: " 6-Jul-85 14:16")
                                                             (* Reads the current state of the 
                                                           mouse and keyboard)
    (SETQ LASTMOUSEX (\XMOUSECOORD))
    (SETQ LASTMOUSEY (\YMOUSECOORD))
    (SETQ LASTMOUSEBUTTONS (LOGXOR (LOGAND (fetch (KEYBOARDEVENT WU) of \LASTKEYSTATE)
                                          \MOUSE.ALLBITS)
                                  \MOUSE.ALLBITS))
    (SETQ LASTKEYBOARD (\EVENTKEYS))
    (SETQ LASTSCREEN \CURSORSCREEN)
    NIL])

(\EVENTKEYS
  [LAMBDA NIL                                            (* rmk%: " 4-JUN-81 22:58")
          (* Returns the state of the various keys that are represented in mouse events)

    (LOGOR (COND
              ((KEYDOWNP 'LOCK)
               128)
              (T 0))
           (COND
              ((KEYDOWNP 'LSHIFT)
               64)
              (T 0))
           (COND
              ((KEYDOWNP 'CTRL)
               32)
              (T 0))
           (COND
              ((KEYDOWNP 'RSHIFT)
               8)
              (T 0))
           (COND
              ((KEYDOWNP 'BLANK-TOP)
               4)
              (T 0))
           (COND
              ((KEYDOWNP 'BLANK-MIDDLE)
               2)
              (T 0))
           (COND
              ((KEYDOWNP 'BLANK-BOTTOM)
               1)
              (T 0])
)
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(RPAQQ HARDCURSORHEIGHT 16)

(RPAQQ HARDCURSORWIDTH 16)


(CONSTANTS (HARDCURSORHEIGHT 16)
       (HARDCURSORWIDTH 16))
)
(DECLARE%: EVAL@COMPILE 

(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD)
)

(* "END EXPORTED DEFINITIONS")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS \SETMOUSEXY MACRO [(XPOS YPOS)
                                     (PROGN (SELECTC \MACHINETYPE
                                                (\DAYBREAK (\DoveMisc.SetMousePosition XPOS YPOS))
                                                (\MAIKO (SUBRCALL SETMOUSEXY XPOS YPOS))
                                                (\DANDELION (do (PROGN (replace (IOPAGE
                                                                                         NEWMOUSEX)
                                                                              of \IOPAGE
                                                                              with XPOS)
                                                                           (replace (IOPAGE
                                                                                         NEWMOUSEY)
                                                                              of \IOPAGE
                                                                              with YPOS))
                                                               repeatuntil
                                                               (ILESSP (fetch (IOPAGE 
                                                                                        NEWMOUSESTATE
                                                                                         )
                                                                          of \IOPAGE)
                                                                      32768))
                                                             (* ; 
                                                   "smash position until mouse says it is not busy")
                                                            (replace (IOPAGE NEWMOUSEX)
                                                               of \IOPAGE with XPOS)
                                                            (replace (IOPAGE NEWMOUSEY)
                                                               of \IOPAGE with YPOS)
                                                            (replace (IOPAGE NEWMOUSESTATE)
                                                               of \IOPAGE with 32768))
                                                NIL)
                                            (PROGN (\PUTBASE \EM.MOUSEX 0 XPOS)
                                                   (\PUTBASE \EM.MOUSEY 0 YPOS])
)

(* "END EXPORTED DEFINITIONS")


(DECLARE%: EVAL@COMPILE 

(PUTPROPS \XMOUSECOORD MACRO (NIL (IPLUS \CURSORHOTSPOTX (SIGNED (\GETBASE \EM.CURSORX 0)
                                                                        BITSPERWORD))))

(PUTPROPS \YMOUSECOORD MACRO [NIL (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT)
                                                 (IPLUS \CURSORHOTSPOTY (SIGNED (\GETBASE \EM.CURSORY
                                                                                       0)
                                                                               BITSPERWORD])
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(MOVD 'CURSOR 'SETCURSOR)

(MOVD '\CURSORPOSITION '\SETCURSORPOSITION)


(RPAQ \SFPosition (CREATEPOSITION))
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE

(BLOCKRECORD KEYBOARDEVENT 
             ((W0 WORD)
              (W1 WORD)
              (W2 WORD)
              (W3 WORD)
              (WU WORD)
              (W4 WORD)
              (W5 WORD)
              (TIME FIXP)
              (MOUSESTATE BITS 3)
              (1SHIFT FLAG)
              (2SHIFT FLAG)
              (LOCK FLAG)
              (CTRL FLAG)
              (META FLAG)
              (FONT FLAG)
              (USERMODE1 FLAG)
              (USERMODE2 FLAG)
              (USERMODE3 FLAG)
              (ALTGRAPH FLAG)
              (DEADKEYPENDING FLAG)                          (* ; "T if the last key was a dead (accent) key, and we should generate an accented character if possible.")
              (NIL BITS 2)
              (MOUSEX WORD)
              (MOUSEY WORD)
              (DEADKEY-ALIST XPOINTER)                       (* ; 
                                    "The ALIST describing accents possible from teh last dead key.")
              )
             (CREATE (\ALLOCBLOCK (FOLDHI \KEYBOARDEVENT.SIZE WORDSPERCELL)))
             W0 _ ALLUP W1 _ ALLUP W2 _ ALLUP W3 _ ALLUP W4 _ ALLUP W5 _ ALLUP WU _ ALLUP MOUSESTATE
             _ \DLMOUSE.UP [ACCESSFNS KEYBOARDEVENT ((SIZE (INDEXF (fetch MOUSEY of DATUM)))
                                                     (SHIFT (OR (fetch (KEYBOARDEVENT 1SHIFT)
                                                                       DATUM)
                                                                (fetch (KEYBOARDEVENT 2SHIFT)
                                                                       DATUM)))
                                                     (SHIFTORLOCK (OR (fetch (KEYBOARDEVENT
                                                                                  SHIFT)
                                                                             DATUM)
                                                                      (fetch (KEYBOARDEVENT
                                                                                  LOCK)
                                                                             DATUM]
             LOCK _ (XKEYDOWNP 'LOCK)
             TIME _ 0 DEADKEYPENDING _ NIL)
)

(DECLARE%: EVAL@COMPILE 

(RPAQ \KEYBOARDEVENT.FIRST NRINGINDEXWORDS)

(RPAQQ \KEYBOARDEVENT.SIZE 14)

(RPAQ \KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383)))


[CONSTANTS (\KEYBOARDEVENT.FIRST NRINGINDEXWORDS)
       \KEYBOARDEVENT.SIZE
       (\KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383]
)
)
(DEFINEQ

(MACHINETYPE
  [LAMBDA NIL                                            (* ; "Edited 30-Mar-88 10:27 by Snow")

    (SELECTC (fetch MachineType of \InterfacePage)
        (\DORADO 'DORADO)
        (\DANDELION 'DANDELION)
        (\DAYBREAK                                           (* This is \DAYBREAK internally)
                   'DOVE)
        (\MAIKO 'MAIKO)
        NIL])

(SETMAINTPANEL
  [LAMBDA (N)                                            (* mpl "21-Jul-85 18:15")
    (SELECTC \MACHINETYPE
        (\DANDELION (replace DLMAINTPANEL of \IOPAGE with N))
        (\DOLPHIN ((OPCODES MISC1 3)
                   (\DTEST N 'SMALLP)))
        (\DAYBREAK ((OPCODES DOVEMISC 2)
                    (\DTEST N 'SMALLP)))
        NIL])
)



(* ; "DLion beeper")

(DEFINEQ

(BEEPON
  [LAMBDA (FREQ)                                      (* ; "Edited 10-May-88 18:17 by MASINTER")
    (SELECTC \MACHINETYPE
        (\DANDELION (while (IGEQ (fetch DLBEEPCMD of \IOPAGE)
                                     32768) do (BLOCK))
                    (replace DLBEEPFREQ of \IOPAGE with (IQUOTIENT 1843200
                                                                           (IMAX FREQ 29)))
                    (replace DLBEEPCMD of \IOPAGE with 32768))
        (\DAYBREAK (\DoveMisc.BeepOn FREQ))
        (\MAIKO (SUBRCALL KEYBOARDBEEP T FREQ))
        (PROGN NIL))
    NIL])

(BEEPOFF
  [LAMBDA NIL                                         (* ; "Edited 10-May-88 18:17 by MASINTER")
    (SELECTC \MACHINETYPE
        (\DANDELION (while (IGEQ (fetch DLBEEPCMD of \IOPAGE)
                                     32768) do (BLOCK))
                    (replace DLBEEPCMD of \IOPAGE with 32769))
        (\DAYBREAK (\DoveMisc.BeepOff))
        (\MAIKO (SUBRCALL KEYBOARDBEEP NIL NIL))
        (PROGN NIL))
    NIL])
)
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0 
       \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.KBDAD4 \EM.KBDAD5 \EM.DISPINTERRUPT \EM.DISPLAYHEAD 
       \EM.CURSORBITMAP \MACHINETYPE \DEFAULTKEYACTION \COMMANDKEYACTION \CURRENTKEYACTION 
       \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY)
)

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(WITHOUT-INTERRUPTS
  [NLAMBDA (FORM)                                        (* lmm "18-Apr-85 02:53")
    (PROG (VAL)
          (\KEYBOARDOFF)
          (SETQ VAL (DISPLAYDOWN FORM))
          (\KEYBOARDON)
          (RETURN VAL])
)



(* ; "Compile locked fns together for locality")

(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY

(BLOCK%: NIL FLIPCURSORBAR \KEYHANDLER \KEYHANDLER1 \TRACKCURSOR \PERIODIC.INTERRUPTFRAME 
       \TIMER.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS \DOTRANSITIONS \DECODETRANSITION \EVENTKEYS 
       \HARDCURSORUP \DOMOUSECHORDING \KEYBOARDOFF \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP
       \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN)
)
(DECLARE%: DONTCOPY 

(ADDTOVAR INEWCOMS
          (ALLOCAL (ADDVARS (LOCKEDFNS FLIPCURSORBAR \SETIOPOINTERS \KEYHANDLER \KEYHANDLER1 
                                   \CONTEXTAPPLY \LOCKPAGES \DECODETRANSITION \SMASHLINK \INCUSECOUNT
                                   LLSH \MAKEFREEBLOCK \DECUSECOUNT \MAKENUMBER \ADDBASE 
                                   \PERIODIC.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS 
                                   \TIMER.INTERRUPTFRAME \CAUSEINTERRUPT \DOMOUSECHORDING 
                                   \KEYBOARDOFF \TRACKCURSOR \HARDCURSORUP \HARDCURSORPOSITION 
                                   \HARDCURSORDOWN \SOFTCURSORUP \SOFTCURSORUPCURRENT 
                                   \SOFTCURSORPOSITION \SOFTCURSORDOWN \SOFTCURSORPILOTBITBLT)
                          (LOCKEDVARS \InterfacePage \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR 
                                 \SOFTCURSORWIDTH \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP 
                                 \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2 
                                 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 
                                 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH 
                                 \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE 
                                 \PENDINGINTERRUPT \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY
                                 \LASTUSERACTION \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING 
                                 SCREENWIDTH SCREENHEIGHT \TIMER.INTERRUPT.PENDING \EM.MOUSEX 
                                 \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN 
                                 \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.DISPINTERRUPT 
                                 \EM.CURSORBITMAP \EM.KBDAD4 \EM.KBDAD5 \MISCSTATS \RCLKSECOND))))

(ADDTOVAR RDCOMS (FNS \SETIOPOINTERS))
)

(PUTPROPS LLKEY FILETYPE :BCOMPL)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML WITHOUT-INTERRUPTS)

(ADDTOVAR LAMA CURSORPROP METASHIFT MOUSECHORDWAIT)
)
(PUTPROPS LLKEY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 1990 
1992 1999 1920 2000 2018))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (14799 21895 (BKSYSCHARCODE 14809 . 15158) (\CLEARSYSBUF 15160 . 15718) (\GETKEY 15720
 . 16895) (\NSYSBUFCHARS 16897 . 17537) (\SAVESYSBUF 17539 . 19151) (\SYSBUFP 19153 . 19457) (
\GETSYSBUF 19459 . 19639) (\PUTSYSBUF 19641 . 20855) (\PEEKSYSBUF 20857 . 21893)) (23192 59371 (
\KEYBOARDINIT 23202 . 24925) (\KEYBOARDEVENTFN 24927 . 29627) (\ALLOCLOCKED 29629 . 30219) (
\SETIOPOINTERS 30221 . 34690) (\KEYBOARDOFF 34692 . 35039) (\KEYBOARDON 35041 . 35353) (\KEYHANDLER 
35355 . 35486) (\KEYHANDLER1 35488 . 42806) (\RESETKEYBOARD 42808 . 44317) (\DOMOUSECHORDING 44319 . 
47990) (\DOTRANSITIONS 47992 . 48669) (\DECODETRANSITION 48671 . 55360) (MOUSECHORDWAIT 55362 . 56045)
 (\TRACKCURSOR 56047 . 59369)) (93113 116472 (KEYACTION 93123 . 93967) (KEYACTIONTABLE 93969 . 95151) 
(KEYBOARDTYPE 95153 . 96255) (RESETKEYACTION 96257 . 98016) (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS 
98018 . 101425) (\KEYACTION1 101427 . 112048) (KEYDOWNP 112050 . 112385) (KEYNUMBERP 112387 . 112585) 
(\KEYNAMETONUMBER 112587 . 113281) (MODIFY.KEYACTIONS 113283 . 114144) (METASHIFT 114146 . 115090) (
SHIFTDOWNP 115092 . 116470)) (116535 116831 (SETUP.OFFICE.KEYBOARD 116545 . 116829)) (119841 121553 (
\INIT.KEYBOARD.STREAM 119851 . 121551)) (121818 138195 (\DOBUFFEREDTRANSITIONS 121828 . 137258) (
\TIMER.INTERRUPTFRAME 137260 . 137985) (\PERIODIC.INTERRUPTFRAME 137987 . 138193)) (138449 142526 (
\HARDCURSORUP 138459 . 140341) (\HARDCURSORPOSITION 140343 . 142379) (\HARDCURSORDOWN 142381 . 142524)
) (142527 166587 (CURSOR.INIT 142537 . 146237) (\CURSORDESTINATION 146239 . 148557) (\SOFTCURSORUP 
148559 . 153813) (\SOFTCURSORUPCURRENT 153815 . 160851) (\SOFTCURSORPOSITION 160853 . 161618) (
\SOFTCURSORDOWN 161620 . 162328) (CURSORPROP 162330 . 162672) (GETCURSORPROP 162674 . 162862) (
PUTCURSORPROP 162864 . 164019) (\CURSORBITSPERPIXEL 164021 . 166137) (\CURSORIMAGEPROPNAME 166139 . 
166363) (\CURSORMASKPROPNAME 166365 . 166585)) (166588 184538 (CURSORCREATE 166598 . 169273) (CURSOR 
169275 . 171087) (\CURSOR-VALID-P 171089 . 172176) (\CURSORUP 172178 . 173893) (\CURSORPOSITION 173895
 . 176423) (\CURSORDOWN 176425 . 176658) (ADJUSTCURSORPOSITION 176660 . 177238) (CURSORPOSITION 177240
 . 178782) (CURSORSCREEN 178784 . 179440) (CURSOREXIT 179442 . 180833) (FLIPCURSOR 180835 . 181961) (
FLIPCURSORBAR 181963 . 182943) (LASTMOUSEX 182945 . 183199) (LASTMOUSEY 183201 . 183455) (
CREATEPOSITION 183457 . 183663) (POSITIONP 183665 . 183949) (CURSORHOTSPOT 183951 . 184536)) (185776 
187324 (GETMOUSESTATE 185786 . 186445) (\EVENTKEYS 186447 . 187322)) (193751 194547 (MACHINETYPE 
193761 . 194161) (SETMAINTPANEL 194163 . 194545)) (194577 195716 (BEEPON 194587 . 195240) (BEEPOFF 
195242 . 195714)) (196167 196430 (WITHOUT-INTERRUPTS 196177 . 196428)))))
STOP
\ No newline at end of file
diff --git a/sources/MAKEINIT.LCOM.~9~ b/sources/MAKEINIT.LCOM.~9~
deleted file mode 100644
index 78c18b63..00000000
Binary files a/sources/MAKEINIT.LCOM.~9~ and /dev/null differ
diff --git a/sources/MAKEINIT.~1~ b/sources/MAKEINIT.~1~
deleted file mode 100644
index 617a16be..00000000
--- a/sources/MAKEINIT.~1~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "27-Oct-92 14:10:38" "{Pele:mv:envos}<LispCore>Sources>MAKEINIT.;7" 26118  

      changes to%:  (FNS I.ATOMNUMBER I.\ATOMCELL)
                    (FILES MEM)

      previous date%: "25-Jan-91 16:00:30" "{Pele:mv:envos}<LispCore>Sources>MAKEINIT.;3")


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT MAKEINITCOMS)

(RPAQQ MAKEINITCOMS
       ((FNS LOADMAKEINIT LOADMKIFILES RELOAD MAKEINIT MKI.START)
        (COMS                                                (* ; 
                                     "reading compiled files and processing well-known expressions")
              (FNS MKI.PASSFILE SCRATCHARRAY DOFORM CONSTFORMP NOTICECOMS EVALFORMAKEINIT)
              (FNS I.ADDTOVAR I.DECLARE%: I.DEFINE-FILE-INFO I.FILECREATED I.PUTPROPS I.RPAQ I.RPAQQ
                   I.RPAQ? I.SETTOPVAL I.NOUNDO)
              (PROP MKI ADDTOVAR DECLARE%: DEFINE-FILE-INFO FILECREATED PUTPROPS RPAQ RPAQ? RPAQQ 
                    LISPXPRINT PRETTYCOMPRINT * SETTOPVAL SETQQ SETQ /SETTOPVAL))
        (FNS I.ATOMNUMBER I.\ATOMCELL I.FIXUPNUM I.FIXUPPTR I.FIXUPSYM I.WORDSPERNAMEENTRY 
             I.SETSTKNTOFFSET)
        (COMS                                                (* ; "stuff for MAXC")
              (FNS MKI.ATOM MKI.IEEE))
        [COMS                                                (* ; 
                  "stuff to maintain symbol values, prop lists during makeinit--all dumped at end.")
              (FNS MKI.DSET MKI.ADDTO MKI.PUTPROP)
              (VARS (MKI.ARRAY)
                    (MKI.TVHA (HASHARRAY 400))
                    (MKI.PLHA (HASHARRAY 150))
                    (MKI.ATOMARRAY (HASHARRAY 5000))
                    (INIT.EXT 'SYSOUT]
        (COMS (FNS DUMPVP BOUTZEROS BIN16 BOUT16)
              (VARS (MKI.FirstDataByte 1024)
                    (MKI.Page0Byte 512)
                    (MKI.DATE (DATE))
                    MKI.CODESTARTOFFSET MKI.SEQUENTIAL PRINTEXPRS))
        (INITVARS (PRINTEXPRS T)
               (REMOTECOMPILE.EXT COMPILE.EXT))
        [DECLARE%: DONTEVAL@LOAD DOCOPY (P (PUTPROP (NAMEFIELD (INPUT)
                                                           T)
                                                  'LOADDATE
                                                  (GETFILEINFO (INPUT)
                                                         'ICREATIONDATE]
        (DECLARE%: EVAL@COMPILE (PROP MACRO SETXVAR IEQ)
               DONTCOPY
               (FILES (LOADCOMP)
                      MEM))))
(DEFINEQ

(LOADMAKEINIT
(LAMBDA (LARGEFLG) (* lmm "31-JUL-81 14:27") (SELECTQ (SYSTEMTYPE) ((D ALTO)) (PROGN (ADDTOVAR DIRECTORIES BLISP) (GCGAG 1000) (COND ((NOT LARGEFLG) (SETSEPR (QUOTE (%| 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26)) 1 FILERDTBL) (MINFS 45000 (QUOTE ARRAYP)) (MINFS 10000 (QUOTE FIXP)) (MINFS 3000 (QUOTE STRING.CHARS)) (MINFS 2000 (QUOTE ATOM.CHARS)))) (MOVD? (QUOTE NILL) (QUOTE MKNUMATOM)) (* ;; "This is a kludge to get around the problem that, while MKATOM is in LLNEW, MKNUMATOM is not, and MKATOM calls MKNUMATOM when given an atom beginning with a digit.  It turns out that MKNUMATOM will always return NIL in the cases called from MAKEINIT because MAKEINIT is merely copying things which it knows are really LITATOM and spelled like it.") (MOVD? (QUOTE *) (QUOTE BLOCKRECORD)) (PUTDQ? FIXSPELL1 (LAMBDA (OLD NEW) (PRINT (LIST OLD (QUOTE ->) NEW) T T))))) (LOADMKIFILES) (SELECTQ (SYSTEMTYPE) ((D ALTO)) (PROGN (MINFS 10000 (QUOTE ALTOPOINTER)) (* ; "doesn't work until after datatype declaration has been loaded") (RECLAIM (QUOTE ARRAYP)) (RECLAIM (QUOTE ATOM.CHARS)) (MINFS 10000 (QUOTE ARRAYP)) (MINFS 5000 (QUOTE LISTP)) (SYSOUT (QUOTE MKI.SAV)))))
)

(LOADMKIFILES
(LAMBDA NIL (* mjs "13-Mar-84 14:41") (for X in (UNION MAKEINITFILES (SELECTQ (SYSTEMTYPE) ((ALTO D) NIL) MAXC.MAKEINITFILES)) do (RELOAD (PACKFILENAME (QUOTE BODY) X (QUOTE EXTENSION) COMPILE.EXT))))
)

(RELOAD
(LAMBDA (FILE) (* lmm "13-APR-81 21:16") (PROG (DATE FULLFILENAME) RETRY (COND ((ILESSP (OR (GETPROP FILE (QUOTE LOADDATE)) MIN.INTEGER) (SETQ DATE (GETFILEINFO (SETQ FULLFILENAME (OR (FINDFILE FILE T) (GO NOTFOUND))) (QUOTE ICREATIONDATE)))) (LOAD FULLFILENAME T) (PUTPROP FILE (QUOTE LOADDATE) DATE))) (RETURN T) NOTFOUND (COND ((GETP (NAMEFIELD FILE) (QUOTE FILEDATES)) (PRINT (CONS FILE (QUOTE (already loaded))) T) (RETURN))) (ERROR FILE "not found.") (GO RETRY)))
)

(MAKEINIT
  [LAMBDA (VERSIONS TYPE TOFILE LOADUPDIRS FONTDIRS)     (* ; "Edited 19-Jul-90 17:26 by jds")
    (LOADMKIFILES)                                       (* ; 
                                    "Load the files that have to be here to start making the init.")
    (PROG ([TYPELST (OR (LISTP TYPE)
                        (OR (CDR (ASSOC TYPE MAKEINITTYPES))
                            (ERROR TYPE '?]
           FILES SIZEGUESS AFTERINITFILESET EXPRESSIONS)

     (* ;; "TYPELST is a list of the form (type file-list after-init-files init-size-guess)")

          (SETQ FILES (CADR TYPELST))
          (SETQ AFTERINITFILESET (CADDR TYPELST))
          (SETQ SIZEGUESS (CADDDR TYPELST))
          (RESETLST
              [RESETSAVE (OUTPUT (SETQ TOFILE
                                  (OPENSTREAM (PACKFILENAME.STRING 'BODY (OR TOFILE (CAR TYPELST)
                                                                             'XXX)
                                                     'EXTENSION INIT.EXT)
                                         'OUTPUT
                                         'NEW 8 (COND
                                                   [NIL      (* ; 
                             "Can't do this until we can do GETFILEPTR on a sequential output file")
                                                        (APPEND MKI.SEQUENTIAL '((TYPE BINARY))
                                                               (AND SIZEGUESS
                                                                    (CONS (LIST 'LENGTH
                                                                                (UNFOLD SIZEGUESS 
                                                                                       BYTESPERPAGE]
                                                   (T '((TYPE BINARY]
              (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (FL)
                                               (AND (OPENP FL)
                                                    (CLOSEF FL))
                                               (AND RESETSTATE (DELFILE (FULLNAME FL]
                                   TOFILE))
              (PROG ((OUTX TOFILE))
                    (SETQ DIRECTORIES LOADUPDIRS)
                    (MKI.START)
                    (for X in FILES do (MKI.PASSFILE X))

               (* ;; "Generally loads the files in 0LISPSET and 1LISPSET, with 2LISPSET getting loaded immediately after the init starts.")

                    (AND LOADUPDIRS (MKI.DSET 'LOADUPDIRECTORIES LOADUPDIRS))
                    (AND FONTDIRS (MKI.DSET 'DISPLAYFONTDIRECTORIES FONTDIRS))
                    [COND
                       (AFTERINITFILESET                     (* ; "Load stuff that has to be loaded before we can call LOADUP.  Ugly expression here is because FILESLOAD is on MACHINEINDEPENDENT.")
                        [MKI.ADDTO
                         'MAKEINIT.EXPRESSIONS
                         `((MAPC ',(EVAL AFTERINITFILESET)
                                 (FUNCTION (LAMBDA (FILE)
                                             (OR [SOME LOADUPDIRECTORIES
                                                       (FUNCTION (LAMBDA (DIR FL)
                                                                   (COND
                                                                      ((SETQ FL
                                                                        (INFILEP (PACKFILENAME.STRING
                                                                                  'DIRECTORY DIR
                                                                                  'NAME FILE
                                                                                  'EXTENSION 
                                                                                  COMPILE.EXT)))
                                                                       (LOAD FL 'SYSLOAD)
                                                                       T]
                                                 (PRINT (CONS FILE '(not found))
                                                        T]
                        (MKI.ADDTO 'BOOTFILES '(MAKEINIT.EXPRESSIONS]
                    (I.MAKEINITLAST VERSIONS)))
          (RETURN (FULLNAME TOFILE])

(MKI.START
(LAMBDA NIL (* bvm%: "12-Dec-84 15:23") (SETQ RESETPTR) (SETQ RESETPC) (BOUTZEROS MKI.FirstDataByte) (CLRHASH MKI.TVHA) (CLRHASH MKI.PLHA) (CLRHASH MKI.ATOMARRAY) (RESETMEMORY) (SETQ MKI.VALUES (for X in INITVALUES bind Y collect (SET (SETQ Y (PACK* "I." (SUBSTRING (CAR X) 2 -1))) (EVAL (CADR X))) Y)) (SETQ MKI.PTRS (for X in INITPTRS bind Y collect (SET (SETQ Y (PACK* "I." (SUBSTRING (CAR X) 2 -1))) (CADR X)) Y)) (I.MAKEINITFIRST) (MKI.DSET NIL NIL) (MKI.DSET T T) (MKI.DSET (QUOTE MAKEINITDATES) (LIST MKI.DATE (DATE))) (for X in INITCONSTANTS when (NEQ (CAR X) (QUOTE *)) do (I.FSETVAL (CAR X) (COND ((LISTP (CADR X)) (I.VAG2 (CAADR X) (CADR (CADR X)))) (T (I.\COPY (CADR X)))))))
)
)



(* ; "reading compiled files and processing well-known expressions")

(DEFINEQ

(MKI.PASSFILE
(LAMBDA (FILESET) (* ; "Edited 30-Mar-87 17:17 by bvm:") (* ;;; "Read a DCOM file and load its contents into the INIT.") (* ;;; "FILESET can be one of a number, which is a LISPSET number, or a list of file names, or a file name") (COND ((NUMBERP FILESET) (* ; "We were given a nLISPSET number.  Pack it up to get the list of files") (MKI.PASSFILE (EVALV (PACK* FILESET (QUOTE LISPSET))))) ((LISTP FILESET) (* ; "We were given a list of file names") (MAPC FILESET (FUNCTION MKI.PASSFILE))) (T (* ; "It's a file name.  Read it in.") (INPUT (SETQ FILESET (OPENSTREAM (OR (FINDFILE (PACKFILENAME.STRING (QUOTE BODY) FILESET (QUOTE EXTENSION) REMOTECOMPILE.EXT) T) FILESET) (QUOTE INPUT) (QUOTE OLD) 8 MKI.SEQUENTIAL))) (MKI.ADDTO (QUOTE LOADEDFILELST) (LIST (SETQ FILESET (FULLNAME FILESET)))) (PRINT FILESET T T) (LET* ((FILEROOT (NAMEFIELD FILESET)) (COMSNAMES (LIST (PACK* FILEROOT (QUOTE COMS)))) SKIPVARS MEXPRS X) (DECLARE (SPECVARS COMSNAMES SKIPVARS MEXPRS)) (* ; " used by I.RPAQQ and DOFORM") (* ;;; "Loop here reading from the dcom file into the init.") (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (until (SELECTQ (SETQ X (READ)) ((STOP NIL) (* ; "End of file") T) NIL) do (COND ((NLISTP X) (* ;; "Start of a code object.  Skip the code indicator (assume it says to read with DCODERD) and read the code") (IF (NOT (LITATOM (READ))) THEN (ERROR "Bad compiled function" X)) (I.DCODERD X)) (T (* ; "It's a form.  go either do it now or add it to the forms to execute inside the init.") (DOFORM X))) finally (COND ((CAR MEXPRS) (* ; "There are expressions to be executed in the INIT when it comes up.  Save them.") (MKI.ADDTO (SETQ FILESET (PACK* FILEROOT ".EXPRESSIONS")) (CAR MEXPRS)) (MKI.ADDTO (QUOTE BOOTFILES) (LIST FILESET)))))) (CLOSEF (INPUT))))))
)

(SCRATCHARRAY
(LAMBDA (NBYTES ALIGN) (* ; "Edited 30-Mar-87 16:20 by bvm:") (COND ((OR (NULL MKI.ARRAY) (IGREATERP NBYTES (ARRAYSIZE MKI.ARRAY))) (* ;; "make sure the scratch array is big enough.  Note that the scratch array is unboxed, not code, since we aren't going to be storing legitimate local code in it (let's not fool the garbage collector too much).") (SETQ MKI.ARRAY (create ARRAYP TYP _ \ST.BYTE BASE _ (\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL) UNBOXEDBLOCK.GCT 0 CELLSPERQUAD) LENGTH _ NBYTES ORIG _ 0)))) (for I from 0 to (SUB1 (UNFOLD ALIGN BYTESPERCELL)) do (\BYTESETA MKI.ARRAY I 0)) (* ; "clear the fnheader area") MKI.ARRAY)
)

(DOFORM
(LAMBDA (X NOPROP) (* bvm%: "30-Aug-86 15:36") (* ;;; "Handle a raw form found in a dcom file that's going into a makeinit.") (LET ((FN (GETPROP (CAR X) (QUOTE MKI)))) (if (AND FN (NOT NOPROP)) then (* ; "it's a local command that can be run `renamed' .  Execute it in the local context.") (* ASSERT%: (CALLS I.ADDTOVAR I.DECLARE%: I.DEFINE-FILE-INFO I.DEFLIST I.FILECREATED I.PRETTYDEFMACROS I.PUTPROPS I.RPAQ I.RPAQQ I.SETHASHQ)) (APPLY* FN X) else (* ;; "it's a command that has to be done remotely, since we don't know how to do it from here.  Add it to the collection of init expressions.") (COND (PRINTEXPRS (PRINT X T T))) (SETQ MEXPRS (TCONC MEXPRS X)))))
)

(CONSTFORMP
(LAMBDA (X) (* lmm " 7-MAR-80 08:54") (COND ((LISTP X) (SELECTQ (CAR X) ((QUOTE FUNCTION) X) NIL)) ((LITATOM X) (SELECTQ X (NIL (QUOTE (QUOTE NIL))) (T T) (AND (SETQ X (GETHASH X MKI.TVHA)) (KWOTE (CDR X))))) (T X)))
)

(NOTICECOMS
(LAMBDA (VAL) (* lmm "10-Mar-85 14:51") (for X in VAL when (LISTP X) do (COND ((AND (EQ (CADR X) (QUOTE *)) (LITATOM (CADDR X))) (COND ((EQ (CAR X) (QUOTE COMS)) (push COMSNAMES (CADDR X))) (T (push SKIPVARS (CADDR X))))) (T (SELECTQ (CAR X) ((COMS DECLARE%:) (NOTICECOMS (CDR X))) NIL)))))
)

(EVALFORMAKEINIT
(LAMBDA (FORM) (* bvm%: " 2-NOV-83 15:22") (COND ((LISTP FORM) (SELECTQ (CAR FORM) (MKATOM (COND ((STRINGP (CADR FORM)) (MKATOM (CADR FORM))) (T (HELP)))) (HELP))) ((FIXP FORM) FORM) (T (HELP))))
)
)
(DEFINEQ

(I.ADDTOVAR
(LAMBDA (FORM) (* lmm " 2-DEC-81 23:58") (MKI.ADDTO (CADR FORM) (CDDR FORM))))

(I.DECLARE%:
(LAMBDA (FORM) (* lmm "18-FEB-80 14:04") (PROG ((L FORM) (FLAG T) X FN) LP (COND ((NULL (SETQ L (CDR L))) (RETURN)) ((NLISTP (SETQ X (CAR L))) (SELECTQ X ((EVAL@LOAD DOEVAL@LOAD) (SETQ FLAG T)) (DONTEVAL@LOAD (SETQ FLAG NIL)) NIL)) (T (DOFORM X))) (GO LP)))
)

(I.DEFINE-FILE-INFO
(LAMBDA (FORM) (* bvm%: "30-Aug-86 15:32") (* ;;; "Set reader environment for reading rest of file") (SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO NIL (CDR FORM))))
)

(I.FILECREATED
(LAMBDA (X) (* ; "Edited 12-Jan-88 11:00 by bvm") (* ;; "Form is (FILECREATED date filename . otherstuff)") (COND ((NLISTP (CADDR X)) (* ; "FILENAME a list is for the %"compiled on%" expression") (LET ((NAME (NAMEFIELD (CADDR X)))) (MKI.ADDTO (QUOTE BOOTLOADEDFILES) (LIST NAME)) (MKI.PUTPROP NAME (QUOTE FILEDATES) (LIST (CONS (CADR X) (CADDR X))))))))
)

(I.PUTPROPS
(LAMBDA (FORM) (* lpd%: "29-APR-77 13:22") (MKI.PUTPROP (CADR FORM) (CADDR FORM) (CADDDR FORM))))

(I.RPAQ
(LAMBDA (FORM) (* edited%: "10-Jul-84 14:05") (PROG ((VAL (CADDR FORM)) V) (COND ((SETQ V (CONSTFORMP VAL)) (MKI.DSET (CADR FORM) (EVAL V))) (T (DOFORM (LIST (QUOTE SETTOPVAL) (KWOTE (CADR FORM)) VAL) T)))))
)

(I.RPAQQ
(LAMBDA (FORM) (* lmm "30-APR-80 22:12") (PROG ((ATM (CADR FORM)) (VAL (CADDR FORM))) (COND ((FMEMB ATM COMSNAMES) (NOTICECOMS VAL)) ((FMEMB ATM SKIPVARS)) (T (MKI.DSET ATM VAL)))))
)

(I.RPAQ?
(LAMBDA (FORM) (* lmm " 7-MAR-80 08:36") (PROG ((VAL (CADDR FORM)) V) (COND ((SETQ V (CONSTFORMP VAL)) (MKI.DSET (CADR FORM) (EVAL V))) (T (DOFORM (LIST (QUOTE SETTOPVAL) (KWOTE (CADR FORM)) VAL))))))
)

(I.SETTOPVAL
(LAMBDA (FORM) (* edited%: "10-Jul-84 14:07") (PROG (V) (if (AND (EQ (CAR (LISTP (CADR FORM))) (QUOTE QUOTE)) (SETQ V (CONSTFORMP (CADDR FORM)))) then (MKI.DSET (CADR (CADR FORM)) (EVAL V)) else (DOFORM FORM T))))
)

(I.NOUNDO
(LAMBDA (FORM) (* edited%: "10-Jul-84 14:02") (if (EQ (NTHCHAR (CAR FORM) 1) (QUOTE /)) then (DOFORM (CONS (SUBATOM (CAR FORM) 2 -1) (CDR FORM))) else (SHOULDNT)))
)
)

(PUTPROPS ADDTOVAR MKI I.ADDTOVAR)

(PUTPROPS DECLARE%: MKI I.DECLARE%:)

(PUTPROPS DEFINE-FILE-INFO MKI I.DEFINE-FILE-INFO)

(PUTPROPS FILECREATED MKI I.FILECREATED)

(PUTPROPS PUTPROPS MKI I.PUTPROPS)

(PUTPROPS RPAQ MKI I.RPAQ)

(PUTPROPS RPAQ? MKI I.RPAQ?)

(PUTPROPS RPAQQ MKI I.RPAQQ)

(PUTPROPS LISPXPRINT MKI NILL)

(PUTPROPS PRETTYCOMPRINT MKI NILL)

(PUTPROPS * MKI NILL)

(PUTPROPS SETTOPVAL MKI I.SETTOPVAL)

(PUTPROPS SETQQ MKI I.RPAQQ)

(PUTPROPS SETQ MKI I.RPAQ)

(PUTPROPS /SETTOPVAL MKI I.NOUNDO)
(DEFINEQ

(I.ATOMNUMBER
  [LAMBDA (A)                                 (* ; 
                                                "Edited 27-Oct-92 14:10 by sybalsky:mv:envos")

    (* ;; "Given a symbol, return the symbol's atom #, in the INIT being made.")

    (* ;; 
"NB that this will work only so long as there are no NEW-SYMBOLs in the INIT, because of the LOLOC.")

    (I.LOLOC (COND
                ((LITATOM A)
                 (MKI.ATOM A))
                (T A])

(I.\ATOMCELL
  [LAMBDA (X N)                               (* ; 
                                                "Edited 26-Oct-92 14:24 by sybalsky:mv:envos")
    (LET ((ATOMNO (I.ATOMNUMBER X)))
         (COND
            (NIL 
                 (* ;; "THIS WAS THE PRE-BIGVM CODE:")

                 (LET [(LOC (SELECTC N
                                (10 (I.ATOMNUMBER X))
                                (12 (I.ATOMNUMBER X))
                                (2 (I.ATOMNUMBER X))
                                (8 (I.ATOMNUMBER X))
                                (SHOULDNT]
                      (I.ADDBASE (I.VAG2 N LOC)
                             LOC)))
            [(EQ (LRSH ATOMNO 16)
                 0)                                          (* ; "Xerox Lisp traditional symbol")
             (LET [(LOC (SELECTC N
                            (10 4)
                            (12 2)
                            (2 6)
                            (8 0)
                            (SHOULDNT]
                  (I.ADDBASE (I.VAG2 8 0)
                         (IPLUS LOC (ITIMES 10 ATOMNO]
            (T                                               (* ; 
                                       "New symbol that appears after traditional symbol runs out.")
               (LET [(OFFSET (SELECTC N
                                 (10 4)
                                 (12 2)
                                 (2 6)
                                 (8 0)
                                 (SHOULDNT]
                    (I.ADDBASE ATOMNO OFFSET])

(I.FIXUPNUM
  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited 17-Jul-90 14:28 by jds")

    (* ;; "�2�Perform atom-number fixup for a code block.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)

        (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.")

        (I.FIXUPPTR CA BN NUM))
       (T 
          (* ;; "Otherwise, fill in the two bytes.")

          (\BYTESETA CA (SUB1 BN)
                 (LOGOR (LOGAND (\BYTELT CA (SUB1 BN))
                               (LRSH (LOGXOR MASK 65535)
                                     8))
                        (LOGAND (LRSH (LOGAND NUM MASK)
                                      8)
                               255)))
          (\BYTESETA CA BN (LOGAND NUM 255])

(I.FIXUPPTR
  [LAMBDA (CA BN PTR)                                    (* ; "Edited 22-Jul-90 12:10 by jds")

    (* ;; "Specific for MAXC --- actual ptr is same as simulated ptr")

    (PROG ((LOLOC (I.LOLOC PTR)))
          (\BYTESETA CA (SUB1 BN)
                 (LRSH LOLOC 8))
          (\BYTESETA CA BN (LOGAND LOLOC 255))
          (\BYTESETA CA (IDIFFERENCE BN 2)
                 (LOGOR (\BYTELT CA (IDIFFERENCE BN 2))
                        (I.HILOC PTR])

(I.FIXUPSYM
  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited 23-Jan-91 19:04 by jds")

    (* ;; "�2�Perform SYMBOL fixup for a code block.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)

        (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.")

        (I.FIXUPPTR CA BN (I.ATOMNUMBER NUM)))
       (T 
          (* ;; "Otherwise, fill in the two bytes.")

          (\BYTESETA CA (SUB1 BN)
                 (LOGOR (LOGAND (\BYTELT CA (SUB1 BN))
                               (LRSH (LOGXOR MASK 65535)
                                     8))
                        (LOGAND (LRSH (LOGAND (I.ATOMNUMBER NUM)
                                             MASK)
                                      8)
                               255)))
          (\BYTESETA CA BN (LOGAND (I.ATOMNUMBER NUM)
                                  255])

(I.WORDSPERNAMEENTRY
  [LAMBDA NIL                                            (* ; "Edited 25-Jan-91 15:35 by jds")

    (* ;; "For MAKEINIT, returns the number of words in a name-table entry.")

    (* ;; "For the old 2-byte atom case, it's 1 word; for 3-byte atoms, 2 words.")

    (* ;; "An %"Entry%" means an entry in each half of the name table (symbol & type/offset).")

    (* ;; "While we're building the INIT, react to either :3-BYTE or :3-BYTE-INIT in the target architecture -- we're automatically CROSSCOMPILING as far as this function is concerned.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
        2)
       ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*)
        2)
       (T 1])

(I.SETSTKNTOFFSET
  [LAMBDA (BASE OFFSET TYPE VAL)                         (* ; "Edited 25-Jan-91 16:00 by jds")

    (* ;; "FOR MAKEINIT:  Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
        (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD)
               TYPE)
        (I.FIXUPNUM BASE OFFSET VAL))
       ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*)
        (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD)
               TYPE)
        (I.FIXUPNUM BASE OFFSET VAL))
       (T (I.FIXUPNUM BASE OFFSET (IPLUS TYPE VAL])
)



(* ; "stuff for MAXC")

(DEFINEQ

(MKI.ATOM
(LAMBDA (X) (* lmm "29-JUL-81 22:46") (* ; "for MAXC") (AND X (OR (GETHASH X MKI.ATOMARRAY) (PUTHASH X (COND ((EQ X (QUOTE NOBIND)) PTRNOBIND) (T (I.COPYATOM X))) MKI.ATOMARRAY))))
)

(MKI.IEEE
(LAMBDA (X BOX) (* bvm%: "16-Dec-80 00:44") (* ;; "Converts pdp-10 floating-point number X to IEEE standard for Dolphin, storing (with I.PUTBASE) into BOX.  For MAXC only.") (PROG (MAGNITUDE (SIGN 0) (EXP 0) (FRAC 0)) RETRY (SETQ MAGNITUDE (COND ((MINUSP X) (SETQ SIGN 32768) (IMINUS (OPENR (LOC X)))) (T (OPENR (LOC X))))) (COND ((ZEROP MAGNITUDE) (GO DONE)) ((IEQP (LOGAND MAGNITUDE 67108864) 0) (* ; "unnormalized number???") (SETQ X (FPLUS X 0.0)) (GO RETRY))) (COND ((ILEQ (SETQ EXP (IDIFFERENCE (LRSH MAGNITUDE 27) 2)) 0) (* ;; "Exponent bias is off by 1, plus another 1 because of the implicit high bit.  Thus have to watch for underflow") (ERROR "Unrepresentable floating-point number" X) (SETQ EXP (SETQ SIGN 0)) (* ; "If continued, make it zero") (GO DONE))) (SETQ FRAC (IPLUS (LOGAND (LRSH MAGNITUDE 3) 16777215) (COND ((OR (ILESSP (LOGAND MAGNITUDE 7) 4) (EQ (LOGAND MAGNITUDE 15) 4)) (* ; "Round down") 0) (T 1)))) (COND ((IGREATERP FRAC 16777215) (* ; "Rounding overflowed the high bit") (SETQ FRAC (LRSH FRAC 1)) (* ; "EXP can't overflow, because of bias difference") (SETQ EXP (ADD1 EXP)))) (* ; "FRAC is now a 24-bit fraction with its high bit on") DONE (I.PUTBASE BOX 0 (LOGOR SIGN (LLSH EXP 7) (LOGAND (LRSH FRAC 16) 127))) (I.PUTBASE BOX 1 (LOGAND FRAC 65535))))
)
)



(* ; "stuff to maintain symbol values, prop lists during makeinit--all dumped at end.")

(DEFINEQ

(MKI.DSET
(LAMBDA (A VAL) (* ; "Edited 12-Jan-88 11:03 by bvm") (LET ((LST (GETHASH A MKI.TVHA))) (COND (LST (COND ((NOT (EQUAL VAL (CDR LST))) (EXEC-FORMAT "(Value of ~S changed from ~S to ~S)~%%" A (CDR LST) VAL))) (RPLACD LST VAL)) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA)))))
)

(MKI.ADDTO
(LAMBDA (A VAL) (* lpd%: "29-APR-77 13:20") (PROG ((LST (GETHASH A MKI.TVHA))) (COND (LST (RPLACD LST (UNION VAL (CDR LST)))) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA)))))
)

(MKI.PUTPROP
(LAMBDA (A PROP VAL) (* ; "Edited 12-Jan-88 11:04 by bvm") (LET ((LST (GETHASH A MKI.PLHA))) (COND (LST (COND ((LISTGET LST PROP) (EXEC-FORMAT "(Property ~S of ~S has been changed)~%%" A PROP))) (LISTPUT LST PROP VAL)) (T (PUTHASH A (LIST PROP VAL) MKI.PLHA)))))
)
)

(RPAQQ MKI.ARRAY NIL)

(RPAQ MKI.TVHA (HASHARRAY 400))

(RPAQ MKI.PLHA (HASHARRAY 150))

(RPAQ MKI.ATOMARRAY (HASHARRAY 5000))

(RPAQQ INIT.EXT SYSOUT)
(DEFINEQ

(DUMPVP
(LAMBDA (VP) (* lpd%: "27-APR-77 20:24") (PRIN1 (QUOTE *) T) (WriteoutPage OUTX VP)))

(BOUTZEROS
(LAMBDA (N) (* lmm "16-MAY-81 16:49") (FRPTQ N (\BOUT OUTX 0))))

(BIN16
(LAMBDA (J) (* lmm "16-MAY-81 16:49") (IPLUS (LLSH (\BIN J) 8) (\BIN J))))

(BOUT16
(LAMBDA (J N) (* lmm "16-MAY-81 16:51") (\BOUT J (LRSH N 8)) (\BOUT J (LOGAND N 255))))
)

(RPAQQ MKI.FirstDataByte 1024)

(RPAQQ MKI.Page0Byte 512)

(RPAQ MKI.DATE (DATE))

(RPAQQ MKI.CODESTARTOFFSET 60)

(RPAQQ MKI.SEQUENTIAL ((SEQUENTIAL T)))

(RPAQQ PRINTEXPRS T)

(RPAQ? PRINTEXPRS T)

(RPAQ? REMOTECOMPILE.EXT COMPILE.EXT)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(PUTPROP (NAMEFIELD (INPUT)
                T)
       'LOADDATE
       (GETFILEINFO (INPUT)
              'ICREATIONDATE))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS SETXVAR MACRO [X `(SETQ.NOREF %, (CADAR X)
                                           %,
                                           (CADR X])

(PUTPROPS IEQ MACRO ((X Y)
                             (IEQP X Y)))
DONTCOPY 

(FILESLOAD (LOADCOMP)
       MEM)
)
(PUTPROPS MAKEINIT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991
 1992))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2698 9690 (LOADMAKEINIT 2708 . 3911) (LOADMKIFILES 3913 . 4133) (RELOAD 4135 . 4618) (
MAKEINIT 4620 . 8982) (MKI.START 8984 . 9688)) (9768 13669 (MKI.PASSFILE 9778 . 11571) (SCRATCHARRAY 
11573 . 12222) (DOFORM 12224 . 12901) (CONSTFORMP 12903 . 13137) (NOTICECOMS 13139 . 13447) (
EVALFORMAKEINIT 13449 . 13667)) (13670 15790 (I.ADDTOVAR 13680 . 13774) (I.DECLARE%: 13776 . 14052) (
I.DEFINE-FILE-INFO 14054 . 14244) (I.FILECREATED 14246 . 14620) (I.PUTPROPS 14622 . 14735) (I.RPAQ 
14737 . 14958) (I.RPAQQ 14960 . 15156) (I.RPAQ? 15158 . 15373) (I.SETTOPVAL 15375 . 15607) (I.NOUNDO 
15609 . 15788)) (16426 22289 (I.ATOMNUMBER 16436 . 16927) (I.\ATOMCELL 16929 . 18545) (I.FIXUPNUM 
18547 . 19364) (I.FIXUPPTR 19366 . 19847) (I.FIXUPSYM 19849 . 20797) (I.WORDSPERNAMEENTRY 20799 . 
21554) (I.SETSTKNTOFFSET 21556 . 22287)) (22321 23829 (MKI.ATOM 22331 . 22527) (MKI.IEEE 22529 . 23827
)) (23926 24691 (MKI.DSET 23936 . 24219) (MKI.ADDTO 24221 . 24406) (MKI.PUTPROP 24408 . 24689)) (24865
 25243 (DUMPVP 24875 . 24972) (BOUTZEROS 24974 . 25053) (BIN16 25055 . 25140) (BOUT16 25142 . 25241)))
))
STOP
\ No newline at end of file
diff --git a/sunloadup/LLPARAMS b/sunloadup/LLPARAMS
deleted file mode 100644
index 55b21afc..00000000
--- a/sunloadup/LLPARAMS
+++ /dev/null
@@ -1,1705 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 8)
-(FILECREATED "31-Jan-98 09:16:51" {DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>LLPARAMS.;15 232505Q
-
-      changes to%:  (VARS INITCONSTANTS)
-
-      previous date%: "30-Jan-98 12:43:29" 
-{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>LLPARAMS.;14)
-
-
-(* ; "
-Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1994, 1998 by Syntelligence Systems, Inc.  This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc.  Reverse engineering, reverse compiling and disassembling of object code are prohibited.  Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc.  Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets.  All rights reserved.
-")
-
-(PRETTYCOMPRINT LLPARAMSCOMS)
-
-(RPAQQ LLPARAMSCOMS (
-                         (* ;; 
-                       "This file defines the constants that control how a SYSOUT is laid out.")
-
-                         (FNS MAKERECORD)
-                         
-                         (* ;; "When you change the SYSOUT's layout in this file, you must also")
-
-                         
-                         (* ;; "   Recreate RDSYS in the library, using (DORENAME 'R)")
-
-                         
-                         (* ;; 
-                   "   Recompile DLFIXINIT and anything else that uses the constants defined here.")
-
-                         
-                         (* ;; "   Recompile LLFAULT. recompile VMEM")
-
-                         (DECLARE%: DONTCOPY
-                                (EXPORT (CONSTANTS (WINDFLG T))
-                                       
-                                       (* ;; 
-                         "INITCONSTANTS are constants (e.g. \LISTPDTD) to be defined at init time.")
-
-                                       (VARS INITCONSTANTS MISCSTATSLAYOUT IFPAGELAYOUT 
-                                             MAIKO.IFPAGELAYOUT IOPAGELAYOUT)
-                                       [CONSTANTS * (for X in INITCONSTANTS when (FIXP (CADR X))
-                                                         collect
-                                                         (LIST (CAR X)
-                                                               (CADR X]
-                                       (CONSTANTS * \MPERRORS)
-                                       (GLOBALVARS * (for X in INITCONSTANTS when
-                                                          [AND (NEQ (CAR X)
-                                                                    '*)
-                                                               (NOT (FIXP (CADR X]
-                                                          collect
-                                                          (CAR X)))
-                                       (P * (LIST (MAKERECORD 'MISCSTATS MISCSTATSLAYOUT)
-                                                  (COND ((EQ \MACHINETYPE \MAIKO)
-                                                         (MAKERECORD 'IFPAGE MAIKO.IFPAGELAYOUT))
-                                                        (T (MAKERECORD 'IFPAGE IFPAGELAYOUT)))
-                                                  (MAKERECORD 'IOPAGE IOPAGELAYOUT)))
-                                       (MACROS EMADDRESS EMGETBASE EMPUTBASE EMULATORSEGMENT 
-                                              EMPOINTER EMADDRESSP)))
-                         (PROP MAKEFILE-ENVIRONMENT LLPARAMS)))
-
-
-
-(* ;; "This file defines the constants that control how a SYSOUT is laid out.")
-
-(DEFINEQ
-
-(MAKERECORD
  [LAMBDA (NAME LAYOUT)                                  (* bvm%: "29-NOV-82 17:40")
    (PROG ((I 0)
           PTRS M NAM)
          (RETURN
           `(BLOCKRECORD
             %, NAME %,
             [for X in LAYOUT
                collect (CONS (SETQ NAM (CAR X))
                                  (COND
                                     ((EQ NAM '*)
                                      (CDR X))
                                     (T (PROG1 [COND
                                                  [[FIXP (SETQ M (CAR (SETQ X (CDR X]
                                                   (LIST M (CAR (SETQ X (CDR X]
                                                  (T (SETQ M (SELECTQ (CAR X)
                                                                 ((FIXP FULLXPOINTER) 
                                                                      (OR (EVENP I WORDSPERCELL)
                                                                          (ERROR 
                                                                           "Record field not aligned"
                                                                                 (CONS NAM X)))
                                                                      2)
                                                                 (WORD 1)
                                                                 (SHOULDNT)))
                                                     (LIST (CAR X]
                                            [COND
                                               ((CADDR X)
                                                (SETQ PTRS (CONS (LIST (PACK* NAM 'PTR)
                                                                       `(\ADDBASE DATUM %, I))
                                                                 PTRS]
                                            (add I M))]
             %,.
             [AND PTRS `((ACCESSFNS %, NAME %, PTRS]
             (CREATE (\ALLOCBLOCK %, (FOLDHI I WORDSPERCELL])
-)
-
-
-
-(* ;; "When you change the SYSOUT's layout in this file, you must also")
-
-
-
-
-(* ;; "   Recreate RDSYS in the library, using (DORENAME 'R)")
-
-
-
-
-(* ;; "   Recompile DLFIXINIT and anything else that uses the constants defined here.")
-
-
-
-
-(* ;; "   Recompile LLFAULT. recompile VMEM")
-
-(DECLARE%: DONTCOPY 
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ WINDFLG T)
-
-
-(CONSTANTS (WINDFLG T))
-)
-
-(RPAQQ INITCONSTANTS (
-
-(* ;;; "(LISPNAME VALUE BCPLNAME UCODENAME)")
-
-                          (CDRCODING 1 T T)
-                                                             (* ; 
-                                                  "IF CDRCODING=0, CDR CODING IS OFF, OTHERWISE ON")
-                          
-                          (* ;; "type numbers -- repeated on LLBASIC too")
-
-                          (\SMALLP 1 SMALLTYPE SmallType)
-                          (\FIXP 2 INTEGERTYPE FixpType)
-                          (\FLOATP 3 FLTPTTYPE FloatpType)
-                          (\LITATOM 4 ATOMTYPE AtomType)
-                          (\LISTP 5 LISTTYPE ListType)
-                          (\ARRAYP 6 ARRAYPTRTYPE ArrayType)
-                          (\STRINGP 7 STRINGPTRTYPE)
-                          (\STACKP 10Q)
-                          (\CHARACTERP 11Q)
-                          (\VMEMPAGEP 12Q NIL VMemPagePType)
-                          (\STREAM 13Q NIL STREAMTYPE)
-                          
-                          (* ;; "TYPE TABLE CONSTANTS - - - - - - - - - - - - - - - - - - - - - -")
-
-                          (\TT.TYPEMASK 3777Q TTTypeMask T)
-                          (\TT.NOREF 100000Q NIL T)
-                          (\TT.SYMBOLP 40000Q NIL T)
-                          (\TT.FIXP 20000Q)
-                          (\TT.NUMBERP 10000Q)
-                          (\TT.ATOM 4000Q)
-                          
-                          (* ;; 
-             "page map - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -")
-
-                          (\PMblockSize 40Q PMBLOCKSIZE)
-                          (\STATSsize 10Q T)
-                          (\NumPMTpages 10Q)
-                          (\EmptyPMTEntry 177777Q T)
-                          (\FirstVmemBlock 2 T)
-                          (\MAXVMPAGE 377775Q)
-                          (\MAXVMSEGMENT 377Q)
-                          
-                          (* ;; "interface page")
-
-                          (\IFPValidKey 12743Q T)
-                          
-                          (* ;; "MDS")
-
-                          (\FirstMDSPage 77776Q) (* ; "Was 37776Q pre 16-meg intiial")
-                          (\MaxMDSPage 1777775Q)
-                          (\DefaultSecondMDSPage 177774Q)
-                          (\MDSIncrement 1000Q)
-                          (\PagesPerMDSUnit 2)
-                                                             (* ; 
-                                                           "(FOLDLO \MDSIncrement WORDSPERPAGE)")
-                          
-                          (* ;; "arrays")
-
-                          (\ARRAYSPACE (56Q 0))
-                          (\FirstArraySegment 56Q)
-                          (\FirstArrayPage 27000Q)
-                          (\ARRAYSPACE2 (100Q 0))
-                          (\DefaultSecondArrayPage 100000Q) (* ; "Was 40000Q before 16meg initial")
-                          
-                          (* ;; "stack block constants")
-
-                          (\StackMask 160000Q T T)
-                          (\FxtnBlock 140000Q T T)
-                          (\GuardBlock 160000Q T T)
-                          (\BFBlock 100000Q T T)
-                          (\FreeStackBlock 120000Q T T)
-                          (\NotStackBlock 0)
-                                                             (* ; "none of the above")
-                          (\MinExtraStackWords 40Q T T)
-                          
-                          (* ;; "backspace kludge")
-
-                          (ERASECHARCODE 0 T)
-                          
-                          (* ;; "GC constants")
-
-                          (\HT1CNT 2000Q NIL T)
-                          (\HTSTKBIT 1000Q NIL T)
-                          (\HTCNTMASK 176000Q NIL T)
-                          (\HTMAINSIZE 200000Q NIL T)
-                          (\HTCOLLSIZE 4000000Q NIL T)
-                                                             (* ; "HTCOLL size in words")
-                          (\HTENDFREE 1 NIL T)
-                          (\HTFREEPTR 0 NIL T)
-                          
-                          (* ;; "pointers and lengths of various data spaces")
-
-                          (\ATOMSPACE (0 0)
-                                 (ATOMspace NIL)
-                                 (atomHiVal NIL))
-                          (\AtomHI 0)
-                          (\CHARHI 7)
-                                                             (* ; 
-                                            "overlap character space and the atom hash table space")
-                          (\AtomHashTable (25Q 0)
-                                 (AHTspace AHTbase))
-                          (\AtomHTpages 400Q AHTSIZE)
-                          (\LastAtomPage 377Q)
-                          (\MaxAtomFrLst 177777Q)
-                          (\SMALLPOSPSPACE (16Q 0))
-                          (\SmallPosHi 16Q SMALLPOSspace smallpl)
-                          (\SMALLNEGSPACE (17Q 0))
-                          (\SmallNegHi 17Q SMALLNEGspace smallneg)
-                          (\NumSmallPages 1000Q)
-                          
-                          (* ;; "PNAME SPACEin the old world; used for initial atoms now.")
-
-                          (\PNPSPACE (10Q 0)
-                                 (PNPspace PNPbase))
-                          (\PNAME.HI 10Q)
-                          (\OLDATOMSPACE (54Q 0))
-                                                             (* ; "NEW ATOM SPACE")
-                          (\ATOM.HI 54Q)
-                                                             (* ; "HI PART OF NEW ATOM SPACE")
-                          
-                          (* ;; "Definitions in old atom world")
-
-                          (\DEFSPACE (12Q 0)
-                                 (DEFspace DEFbase)
-                                 (DEFspace DEFbase))
-                          (\DEF.HI 12Q)
-                          (\VALSPACE (14Q 0)
-                                 (TOPVALspace TOPVALbase)
-                                 (VALspace VALbase))
-                          (\VAL.HI 14Q)
-                          (\PLISTSPACE (2 0)
-                                 (PLISTspace PLISTbase))
-                          (\PLIST.HI 2)
-                          (\PAGEMAP (5 0)
-                                 (PAGEMAPspace PAGEMAPbase))
-                          (\NumPageMapPages 400Q)
-                          (\PageMapTBL (24Q 1000Q)
-                                 (PMTspace PMTbase))
-                          (\InterfacePage (24Q 0)
-                                 (INTERFACEspace INTERFACEbase)
-                                 (INTERFACEspace INTERFACEbase))
-                          (\IOPAGE (0 177400Q))
-                          (\DoveIORegion (0 40000Q))
-                          (\IOCBPAGE (0 400Q))
-                          (\FPTOVP (2 0))
-                          (\MDSTypeTable (30Q 0)
-                                 (MDSTYPEspace MDSTYPEbase)
-                                 (MDSTYPEspace MDSTYPEbase))
-                          (\MDSTTsize 2000Q T)
-                                                             (* ; "in Pages")
-                          (\MISCSTATS (24Q 5000Q)
-                                 (STATSspace MISCSTATSbase))
-                          (\UFNTable (24Q 6000Q)
-                                 NIL
-                                 (STATSspace UFNTablebase))
-                          (\UFNTableSize 2)
-                          (\DTDSpaceBase (24Q 10000Q)
-                                 (DTDspace DTDbase)
-                                 (DTDspace DTDbase))
-                          (\DTDSize 22Q T)
-                          (\LISTPDTD (24Q 10132Q))
-                          (\EndTypeNumber 3777Q)
-                          (\LOCKEDPAGETABLE (24Q 70000Q))
-                          (\NumLPTPages 20Q)
-                          (\STACKSPACE (1 0)
-                                 (STACKspace NIL)
-                                 (STACKspace NIL))
-                          (\GuardStackAddr 170000Q)
-                          (\LastStackAddr 177776Q)
-                          (\STACKHI 1 T T)
-                          (\HTMAIN (26Q 0)
-                                 (HTMAINspace HTMAINbase)
-                                 (HTMAINspace HTMAINbase))
-                          (\HTMAINnpages 400Q T)
-                          (\HTOVERFLOW (27Q 0)
-                                 NIL
-                                 (NIL HTOVERFLOWbase))
-                          (\HTBIGCOUNT (27Q 100000Q))
-                          (\HTCOLL (34Q 0)
-                                 NIL
-                                 (HTCOLLspace HTCOLLbase))
-                          (\DISPLAYREGION (22Q 0))
-                          (\D1BCPLspace 0 T LEmubrHiVal)
-                          (\D0BCPLspace 0 T)
-                          
-                          (* ;; "Interface Page locations")
-
-                          (\CurrentFXP 0 T T)
-                          (\ResetFXP 1 T T)
-                          (\SubovFXP 2 T T)
-                          (\KbdFXP 3 T T)
-                          (\HardReturnFXP 4 T T)
-                          (\GCFXP 5)
-                          (\FAULTFXP 6 T T)
-                          (\MiscFXP 16Q T T)
-                          (\TeleRaidFXP 30Q T T)
-                          
-                          (* ;; "emulator segment locations")
-
-                          (DCB.EM 420Q)
-                          (DISPINTERRUPT.EM 421Q)
-                          (CURSORBITMAP.EM 431Q)
-                          (KBDAD0.EM 177034Q)
-                          (KBDAD1.EM 177035Q)
-                          (KBDAD2.EM 177036Q)
-                          (KBDAD3.EM 177037Q)
-                          (UTILIN.EM 177030Q)
-                          (CURSORX.EM 426Q)
-                          (CURSORY.EM 427Q)
-                          (MOUSEX.EM 424Q)
-                          (MOUSEY.EM 425Q)
-                          (\LispKeyMask 20000Q T T)
-                          (\BcplKeyMask 10400Q T T)
-                                                             (* ; "Machine types")
-                          (\MAIKO 3)
-                          (\DOLPHIN 4)
-                          (\DORADO 5)
-                          (\DANDELION 6)
-                          (\DAYBREAK 10Q)
-                          
-                          (* ;; "FOR DLION (AND DAYBREAK)")
-
-                          (\VP.DISPLAY 11000Q)
-                          (\NP.DISPLAY 312Q)
-                                                             (* ; 
-                           "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)")
-                          (\NP.WIDEDOVEDISPLAY 363Q)
-                                                             (* ; 
-                                                           "Wide Dove display 1152x864 pixels")
-                          (\WIDEDOVEDISPLAYWIDTH 2200Q)
-                          (\RP.AFTERDISPLAY 316Q)
-                                                             (* ; "Includes 4 pages for cursor")
-                          (\RP.AFTERDOVEDISPLAY 363Q)
-                                                             (* ; "if big screen")
-                          (\RP.DISPLAY 0)
-                          (\RP.TEMPDISPLAY 5001Q)
-                          (\RP.MISCLOCKED 5364Q)
-                                                             (* ; 
-                                                          "(+ \RP.TEMPDISPLAY \NP.WIDEDOVEDISPLAY)")
-                          (\RP.STACK 1400Q)
-                          (\VP.STACK 400Q)
-                          (\RP.MAP 400Q)
-                          (\NP.MAP 400Q)
-                          (\RP.IOPAGE 1000Q)
-                                                             (* ; 
-                          "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range")
-                          (\RP.DOVEIOCBPAGE 1037Q)
-                          (\RP.DOVEIORGN 1040Q)
-                          (\VP.DOVEIORGN 100Q)
-                          (\DOVEIORGNSIZE 100Q)
-                          (\VP.IOPAGE 377Q)
-                          (\VP.IFPAGE 12000Q)
-                          (\VP.FPTOVP 1000Q)
-                          (\NP.FPTOVP 10000Q)
-                          (\RP.FPTOVP 2000Q)
-                          (\RP.STARTBUFFERS 1200Q)
-                          (\VP.TYPETABLE 14000Q)
-                          (\NP.TYPETABLE 2000Q)
-                          (\RP.TYPETABLE 12000Q)
-                          (\VP.GCTABLE 13000Q)
-                          (\NP.GCTABLE 400Q)
-                          (\RP.GCTABLE 14000Q)
-                          (\VP.GCOVERFLOW 13400Q)
-                          (\NP.GCOVERFLOW 1)
-                          (\RP.GCOVERFLOW 14400Q)
-                          (\FP.IFPAGE 2)
-                          (\VP.IOCBS 1)
-                          (\VP.PRIMARYMAP 12002Q)
-                          (\VP.SECONDARYMAP 2400Q)
-                          (\VP.LPT 12160Q)
-                          (\VP.INITSCRATCH 10Q)
-                          (\VP.RPT 200Q)
-                          (\VP.BUFFERS 332Q)
-                                                             (* ; "DLion processor commands")
-                          (\DL.PROCESSORBUSY 100000Q)
-                          (\DL.SETTOD 100001Q)
-                          (\DL.READTOD 100002Q)
-                          (\DL.READPID 100003Q)
-                          (\DL.BOOTBUTTON 100004Q)))
-
-(RPAQQ MISCSTATSLAYOUT ((STARTTIME FIXP MSstrtTime)
-                            (TOTALTIME FIXP)
-                            (SWAPWAITTIME FIXP T)
-                            (PAGEFAULTS FIXP T)
-                            (SWAPWRITES FIXP T)
-                            (DISKIOTIME FIXP T)
-                            (DISKOPS FIXP T)
-                            (KEYBOARDWAITTIME FIXP T)
-                            (GCTIME FIXP T)
-                            (NETIOTIME FIXP T)
-                            (NETIOOPS FIXP T)
-                            (SWAPTEMP0 FIXP)
-                            (SWAPTEMP1 FIXP)
-                            (RCLKSECOND FIXP)
-                            (SECONDSCLOCK FIXP)
-                            (MILLISECONDSCLOCK FIXP)
-                            (BASECLOCK FIXP)
-                            (RCLKTEMP0 FIXP)
-                            (SECONDSTMP FIXP)
-                            (MILLISECONDSTMP FIXP)
-                            (BASETMP FIXP)
-                            (EXCESSTIMETMP FIXP)
-                            (CLOCKTEMP0 FIXP)
-                            (DISKTEMP0 FIXP)
-                            (DISKTEMP1 FIXP)
-                            (TELERAIDTEMP1 FIXP)
-                            (TELERAIDTEMP2 FIXP)
-                            (TELERAIDTEMP3 FIXP)
-                            (LASTUSERACTION FIXP)
-                            (DLMOUSETIMER FIXP)
-                            (DLMOUSETEMP FIXP)))
-
-(RPAQQ IFPAGELAYOUT ((CurrentFXP WORD)
-                                                             (* ; 
-                                      "First 7 items are FX values for user and 6 system contexts.")
-                         (ResetFXP WORD)
-                         (SubovFXP WORD)
-                         (KbdFXP WORD)
-                         (HardReturnFXP WORD)
-                         (GCFXP WORD)
-                         (FAULTFXP WORD)
-                         (EndOfStack WORD)
-                                                             (* ; 
-                            "Stack high-water mark: address of guard block at current end of stack")
-                         (LVersion WORD)
-                                                             (* ; 
-           "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp")
-                         (MinRVersion WORD)
-                         (MinBVersion WORD)
-                         (RVersion WORD)
-                                                             (* ; 
-                                               "Bcpl fills in the actual microcode, Bcpl versions.")
-                         (BVersion WORD)
-                         (MachineType WORD)
-                         (MiscFXP WORD)
-                                                             (* ; "FX for MISC context")
-                         (Key WORD)
-                                                             (* ; 
-                                                           "= IFPValidKey if vmem consistent.")
-                         (SerialNumber WORD)
-                                                             (* ; 
-                                                           "Pup host number (Dorado/Dolphin)")
-                         (EmulatorSpace WORD)
-                                                             (* ; 
-                                                           "Hiloc of bcpl space (always zero now)")
-                         (ScreenWidth WORD)
-                         (NxtPMAddr WORD)
-                                                             (* ; 
-                                            "Next page to be allocated in secondary page map table")
-                         (NActivePages WORD)
-                                                             (* ; "Length of vmem in use")
-                         (NDirtyPages WORD)
-                                                             (* ; 
-                                                       "not used, but maintained as = NActivePages")
-                         (filePnPMP0 WORD)
-                                                             (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live")
-                         (filePnPMT0 WORD)
-                                                             (* ; 
-                                       "Sysout page number of first page of primary page map table")
-                         (TELERAIDFXP WORD)
-                                                             (* ; "FX for TeleRaid server context")
-                         (NATIVE-START-MEM-PAGE WORD)
-                                                             (* ; 
-                                                           "Unix page where native code starts")
-                         (NATIVE-LENGTH-PAGE WORD)
-                                                             (* ; "Unix page length of native code")
-                         (NATIVE-PAGE-OFFSET WORD)
-                                                             (* ; 
-                                                           "Lisp Disk Page offset  of native code")
-                         (UserNameAddr WORD)
-                                                             (* ; 
-                                 "Addresses in bcpl space (seg 0) of global user name and password")
-                         (UserPswdAddr WORD)
-                         (StackBase WORD)
-                                                             (* ; 
-                                                           "Stack address where user stack starts")
-                         (FAULTHI WORD)
-                                                             (* ; 
-         "Microcode for page fault stores fault address here, then does context switch to FAULTFXP")
-                         (FAULTLO WORD)
-                         (DEVCONFIG WORD)
-                                                             (* ; "IT'S FOR KB,DISP TYPE")
-                                                             (* ; 
-                                   "Formerly REALPAGETABLE, back when it was always in Bcpl space.")
-                         (RPTSIZE WORD)
-                                                             (* ; 
-                                                           "Number of entries in Real Page Table")
-                         (RPOFFSET WORD)
-                                                             (* ; "RP-RPOFFSET => index in table")
-                         (MAXETHERBYTES WORD)
-                                                             (* ; 
-                          "Number of bytes available in a pbi, not counting encapsulation (Dorado)")
-                         (EMBUFVP WORD)
-                                                             (* ; 
-                                                           "VP of a one-page emulator buffer")
-                         (NSHost0 WORD)
-                                                             (* ; "Machine's 48-bit NS host number.  Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in.")
-                         (NSHost1 WORD)
-                         (NSHost2 WORD)
-                         (MDSZone WORD)
-                                                             (* ; 
-                                               "Obsolete -- was used by Dolphin 10MB network code.")
-                         (MDSZoneLength WORD)
-                         (EMUBUFFERS WORD)
-                                                             (* ; 
-                                             "Buffer space in segment 0 for swapping/disk activity")
-                         (EMUBUFLENGTH WORD)
-                                                             (* ; "Number of words of said space")
-                         (LASTNUMCHARS WORD)
-                                                             (* ; "No longer used?")
-                         (SYSDISK WORD)
-                                                             (* ; 
-                                 "Address of sysDisk in Bcpl space -- disk obj for boot partition.")
-                         (ISFMAP WORD)
-                         
-                         (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!")
-
-                         (MISCSTACKFN FULLXPOINTER)
-                         (MISCSTACKARG1 FULLXPOINTER)
-                         (MISCSTACKARG2 FULLXPOINTER)
-                         (MISCSTACKRESULT FULLXPOINTER)
-                         (NRealPages WORD)
-                                                             (* ; "Number pages of real memory")
-                         (LastLockedFilePage WORD)
-                                                             (* ; 
-                         "Last page of vmem that is locked--booting has to load at least that far.")
-                         (LastDominoFilePage WORD)
-                                                             (* ; 
-                                                "Last sysout page reserved for Dandelion microcode")
-                         (FPTOVPStart WORD)
-                                                             (* ; "Sysout page where FPTOVP starts")
-                         (FAKEMOUSEBITS WORD)
-                                                             (* ; 
-                                      "Used to implement fake middle button on 2-button Dandelion.")
-                         (DL24BitAddressable WORD)
-                                                             (* ; 
-                                      "non-zero if DLion capable of addressing 32MB virtual memory")
-                         (REALPAGETABLEPTR FULLXPOINTER)
-                                                             (* ; 
-                            "Address of real page table, set up by Bcpl (but not chained together)")
-                         (DLLastVmemPage WORD)
-                                                             (* ; 
-                                           "DLion booting microcode puts length of vmem file here.")
-                         (FullSpaceUsed WORD)
-                                                             (* ; 
-                                          "Non-zero if vmem beyond initial 8MB has been allocated.")
-                         (FAKEKBDAD4 WORD)
-                         (FAKEKBDAD5 WORD)
-                         
-                         (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with.")
-
-                         (XVmemFmapBase WORD)
-                                                             (* ; 
- "Bcpl stores isf map pointer to each partition here.  First is redundant with ISFMAP field above.")
-                         (NIL WORD)
-                         (NIL WORD)
-                         (XVmemFmapHighBase WORD)
-                                                             (* ; 
-                          "Bcpl stores the highest vm page contained in this or earlier partition.")
-                         (NIL WORD)
-                         (NIL WORD)
-                         (XVmemDiskBase FULLXPOINTER)
-                                                             (* ; 
-      "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).")
-                         (NIL FULLXPOINTER)
-                         (NIL FULLXPOINTER)))
-
-(RPAQQ MAIKO.IFPAGELAYOUT ((CurrentFXP WORD)
-                                                             (* ; 
-                                      "First 7 items are FX values for user and 6 system contexts.")
-                               (ResetFXP WORD)
-                               (SubovFXP WORD)
-                               (KbdFXP WORD)
-                               (HardReturnFXP WORD)
-                               (GCFXP WORD)
-                               (FAULTFXP WORD)
-                               (EndOfStack WORD)
-                                                             (* ; 
-                            "Stack high-water mark: address of guard block at current end of stack")
-                               (LVersion WORD)
-                                                             (* ; 
-           "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp")
-                               (MinRVersion WORD)
-                               (MinBVersion WORD)
-                               (RVersion WORD)
-                                                             (* ; 
-                                               "Bcpl fills in the actual microcode, Bcpl versions.")
-                               (BVersion WORD)
-                               (MachineType WORD)
-                               (MiscFXP WORD)
-                                                             (* ; "FX for MISC context")
-                               (Key WORD)
-                                                             (* ; 
-                                                           "= IFPValidKey if vmem consistent.")
-                               (SerialNumber WORD)
-                                                             (* ; 
-                                                           "Pup host number (Dorado/Dolphin)")
-                               (EmulatorSpace WORD)
-                                                             (* ; 
-                                                           "Hiloc of bcpl space (always zero now)")
-                               (ScreenWidth WORD)
-                               (NxtPMAddr WORD)
-                                                             (* ; 
-                                            "Next page to be allocated in secondary page map table")
-                               (NIL WORD)
-                                                             (* ; 
-                                                          "WAS NActivePages, Length of vmem in use")
-                               (NIL WORD)
-                                                             (* ; 
-                                      "WAS NDirtyPages, not used, but maintained as = NActivePages")
-                               (filePnPMP0 WORD)
-                                                             (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live")
-                               (filePnPMT0 WORD)
-                                                             (* ; 
-                                       "Sysout page number of first page of primary page map table")
-                               (TELERAIDFXP WORD)
-                                                             (* ; "FX for TeleRaid server context")
-                               (NATIVE-START-MEM-PAGE WORD)
-                                                             (* ; 
-                                                           "Unix page where native code starts")
-                               (NATIVE-LENGTH-PAGE WORD)
-                                                             (* ; "Unix page length of native code")
-                               (NATIVE-PAGE-OFFSET WORD)
-                                                             (* ; 
-                                                           "Lisp Disk Page offset  of native code")
-                               (UserNameAddr WORD)
-                                                             (* ; 
-                                 "Addresses in bcpl space (seg 0) of global user name and password")
-                               (UserPswdAddr WORD)
-                               (StackBase WORD)
-                                                             (* ; 
-                                                           "Stack address where user stack starts")
-                               (FAULTHI WORD)
-                                                             (* ; 
-         "Microcode for page fault stores fault address here, then does context switch to FAULTFXP")
-                               (FAULTLO WORD)
-                               (DEVCONFIG WORD)
-                                                             (* ; "IT'S FOR KB,DISP TYPE")
-                                                             (* ; 
-                                   "Formerly REALPAGETABLE, back when it was always in Bcpl space.")
-                               (RPTSIZE WORD)
-                                                             (* ; 
-                                                           "Number of entries in Real Page Table")
-                               (RPOFFSET WORD)
-                                                             (* ; "RP-RPOFFSET => index in table")
-                               (MAXETHERBYTES WORD)
-                                                             (* ; 
-                          "Number of bytes available in a pbi, not counting encapsulation (Dorado)")
-                               (EMBUFVP WORD)
-                                                             (* ; 
-                                                           "VP of a one-page emulator buffer")
-                               (NSHost0 WORD)
-                                                             (* ; "Machine's 48-bit NS host number.  Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in.")
-                               (NSHost1 WORD)
-                               (NSHost2 WORD)
-                               (MDSZone WORD)
-                                                             (* ; 
-                                               "Obsolete -- was used by Dolphin 10MB network code.")
-                               (MDSZoneLength WORD)
-                               (EMUBUFFERS WORD)
-                                                             (* ; 
-                                             "Buffer space in segment 0 for swapping/disk activity")
-                               (EMUBUFLENGTH WORD)
-                                                             (* ; "Number of words of said space")
-                               
-                               (* ;; 
-                             "The following 2 are available if NEW_STOARGE is specified in C")
-
-                               (ProcessSize WORD)
-                                                             (* ; 
-                                                  "Process size for which can be use as LISP space")
-                               (StorageFullState WORD)
-                                                             (* ; "Save last storage state")
-                               (ISFMAP WORD)
-                               
-                               (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!")
-
-                               (MISCSTACKFN FULLXPOINTER)
-                               (MISCSTACKARG1 FULLXPOINTER)
-                               (MISCSTACKARG2 FULLXPOINTER)
-                               (MISCSTACKRESULT FULLXPOINTER)
-                               (NRealPages WORD)
-                                                             (* ; "Number pages of real memory")
-                               (LastLockedFilePage WORD)
-                                                             (* ; 
-                         "Last page of vmem that is locked--booting has to load at least that far.")
-                               (LastDominoFilePage WORD)
-                                                             (* ; 
-                                                "Last sysout page reserved for Dandelion microcode")
-                               (FPTOVPStart WORD)
-                                                             (* ; "Sysout page where FPTOVP starts")
-                               (FAKEMOUSEBITS WORD)
-                                                             (* ; 
-                                      "Used to implement fake middle button on 2-button Dandelion.")
-                               (DL24BitAddressable WORD)
-                                                             (* ; 
-                                      "non-zero if DLion capable of addressing 32MB virtual memory")
-                               (REALPAGETABLEPTR FULLXPOINTER)
-                                                             (* ; 
-                            "Address of real page table, set up by Bcpl (but not chained together)")
-                               (SYSDISK WORD)
-                                                             (* ; 
-                       "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.")
-                               (FullSpaceUsed WORD)
-                                                             (* ; 
-                                          "Non-zero if vmem beyond initial 8MB has been allocated.")
-                               (FAKEKBDAD4 WORD)
-                               (FAKEKBDAD5 WORD)
-                               
-                               (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with.")
-
-                               (XVmemFmapBase WORD)
-                                                             (* ; 
- "Bcpl stores isf map pointer to each partition here.  First is redundant with ISFMAP field above.")
-                               (NIL WORD)
-                               (NIL WORD)
-                               (XVmemFmapHighBase WORD)
-                                                             (* ; 
-                          "Bcpl stores the highest vm page contained in this or earlier partition.")
-                               (NIL WORD)
-                               (NIL WORD)
-                               (XVmemDiskBase FULLXPOINTER)
-                                                             (* ; 
-      "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).")
-                               (NIL FULLXPOINTER)
-                               (NIL FULLXPOINTER)
-                               (DLLastVmemPage FIXP)
-                                                             (* ; 
-                                           "DLion booting microcode puts length of vmem file here.")
-                               (NActivePages FIXP)
-                                                             (* ; "Length of vmem in use")
-                               (NDirtyPages FIXP)
-                                                             (* ; 
-                                                       "not used, but maintained as = NActivePages")
-                               ))
-
-(RPAQQ IOPAGELAYOUT ((NIL 22Q WORD)
-                         (DLMAINTPANEL WORD NIL T)
-                         (DLFLOPPYCMD WORD)
-                         (DLTTYPORTCMD WORD)
-                         (DLPROCESSORCMD WORD)
-                         (NEWMOUSESTATE WORD)
-                         (DLBEEPCMD WORD)
-                         (DLRS232CMISCCOMMAND WORD)
-                         (DLRS232CPUTFLAG WORD)
-                         (DLRS232CGETFLAG WORD)
-                         (NIL 6 WORD)
-                         (DLFLOPPY WORD)
-                         (DLTTYOUT WORD)
-                         (NIL 1 WORD)
-                         (DLTTYIN WORD)
-                         (NIL 1 WORD)
-                         (DLPROCESSOR2 WORD)
-                         (DLPROCESSOR1 WORD)
-                         (DLPROCESSOR0 WORD)
-                         (NEWMOUSEX WORD)
-                         (NEWMOUSEY WORD)
-                         (DLBEEPFREQ WORD)
-                         (DLRS232CPARAMETERCSBLO WORD)
-                         (DLRS232CPARAMETERCSBHI WORD)
-                         (DLRS232CSETRS366STATUS 3 WORD)
-                         (DLRS232CPUTCSBLO WORD)
-                         (DLRS232CPUTCSBHI WORD)
-                         (DLRS232CGETCSBLO WORD)
-                         (DLRS232CGETCSBHI WORD)
-                         (DLRS232CDEVICESTATUS WORD)
-                         (DLRS232CPARAMETEROUTCOME WORD)
-                         (DLTODVALID WORD)
-                         (DLTODLO WORD NIL T)
-                         (DLTODHI WORD)
-                         (DLTODLO2 WORD)
-                         (DLMOUSEX WORD NIL T)
-                         (DLMOUSEY WORD NIL T)
-                         (DLUTILIN WORD NIL T)
-                         (DLKBDAD0 WORD NIL T)
-                         (DLKBDAD1 WORD NIL T)
-                         (DLKBDAD2 WORD NIL T)
-                         (DLKBDAD3 WORD NIL T)
-                         (DLKBDAD4 WORD NIL T)
-                         (DLKBDAD5 WORD NIL T)
-                         (DLLSEPIMAGECSB 40Q WORD)
-                         (DLIOPHARDWARECONFIG WORD)
-                         (NIL 13Q WORD)
-                         (DLRS232CPARAMETERCSBLO.11 WORD)
-                         (DLRS232CPARAMETERCSBHI.11 WORD)
-                         (DLRS232CSETRS366STATUS.11 16Q WORD)
-                         (NIL 74Q WORD)
-                         (DLMAGTAPE 4 WORD)
-                         (DLETHERNET 14Q WORD NIL T)
-                         (NIL 37Q WORD)
-                         (DLDISPINTERRUPT WORD NIL T)
-                         (DLDISPCONTROL WORD)
-                         (DLDISPBORDER WORD)
-                         (DLCURSORX WORD NIL T)
-                         (DLCURSORY WORD NIL T)
-                         (DLCURSORBITMAP 20Q WORD NIL T)))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ CDRCODING 1)
-
-(RPAQQ \SMALLP 1)
-
-(RPAQQ \FIXP 2)
-
-(RPAQQ \FLOATP 3)
-
-(RPAQQ \LITATOM 4)
-
-(RPAQQ \LISTP 5)
-
-(RPAQQ \ARRAYP 6)
-
-(RPAQQ \STRINGP 7)
-
-(RPAQQ \STACKP 10Q)
-
-(RPAQQ \CHARACTERP 11Q)
-
-(RPAQQ \VMEMPAGEP 12Q)
-
-(RPAQQ \STREAM 13Q)
-
-(RPAQQ \TT.TYPEMASK 3777Q)
-
-(RPAQQ \TT.NOREF 100000Q)
-
-(RPAQQ \TT.SYMBOLP 40000Q)
-
-(RPAQQ \TT.FIXP 20000Q)
-
-(RPAQQ \TT.NUMBERP 10000Q)
-
-(RPAQQ \TT.ATOM 4000Q)
-
-(RPAQQ \PMblockSize 40Q)
-
-(RPAQQ \STATSsize 10Q)
-
-(RPAQQ \NumPMTpages 10Q)
-
-(RPAQQ \EmptyPMTEntry 177777Q)
-
-(RPAQQ \FirstVmemBlock 2)
-
-(RPAQQ \MAXVMPAGE 377775Q)
-
-(RPAQQ \MAXVMSEGMENT 377Q)
-
-(RPAQQ \IFPValidKey 12743Q)
-
-(RPAQQ \FirstMDSPage 77776Q)
-
-(RPAQQ \MaxMDSPage 1777775Q)
-
-(RPAQQ \DefaultSecondMDSPage 177774Q)
-
-(RPAQQ \MDSIncrement 1000Q)
-
-(RPAQQ \PagesPerMDSUnit 2)
-
-(RPAQQ \FirstArraySegment 56Q)
-
-(RPAQQ \FirstArrayPage 27000Q)
-
-(RPAQQ \DefaultSecondArrayPage 100000Q)
-
-(RPAQQ \StackMask 160000Q)
-
-(RPAQQ \FxtnBlock 140000Q)
-
-(RPAQQ \GuardBlock 160000Q)
-
-(RPAQQ \BFBlock 100000Q)
-
-(RPAQQ \FreeStackBlock 120000Q)
-
-(RPAQQ \NotStackBlock 0)
-
-(RPAQQ \MinExtraStackWords 40Q)
-
-(RPAQQ ERASECHARCODE 0)
-
-(RPAQQ \HT1CNT 2000Q)
-
-(RPAQQ \HTSTKBIT 1000Q)
-
-(RPAQQ \HTCNTMASK 176000Q)
-
-(RPAQQ \HTMAINSIZE 200000Q)
-
-(RPAQQ \HTCOLLSIZE 4000000Q)
-
-(RPAQQ \HTENDFREE 1)
-
-(RPAQQ \HTFREEPTR 0)
-
-(RPAQQ \AtomHI 0)
-
-(RPAQQ \CHARHI 7)
-
-(RPAQQ \AtomHTpages 400Q)
-
-(RPAQQ \LastAtomPage 377Q)
-
-(RPAQQ \MaxAtomFrLst 177777Q)
-
-(RPAQQ \SmallPosHi 16Q)
-
-(RPAQQ \SmallNegHi 17Q)
-
-(RPAQQ \NumSmallPages 1000Q)
-
-(RPAQQ \PNAME.HI 10Q)
-
-(RPAQQ \ATOM.HI 54Q)
-
-(RPAQQ \DEF.HI 12Q)
-
-(RPAQQ \VAL.HI 14Q)
-
-(RPAQQ \PLIST.HI 2)
-
-(RPAQQ \NumPageMapPages 400Q)
-
-(RPAQQ \MDSTTsize 2000Q)
-
-(RPAQQ \UFNTableSize 2)
-
-(RPAQQ \DTDSize 22Q)
-
-(RPAQQ \EndTypeNumber 3777Q)
-
-(RPAQQ \NumLPTPages 20Q)
-
-(RPAQQ \GuardStackAddr 170000Q)
-
-(RPAQQ \LastStackAddr 177776Q)
-
-(RPAQQ \STACKHI 1)
-
-(RPAQQ \HTMAINnpages 400Q)
-
-(RPAQQ \D1BCPLspace 0)
-
-(RPAQQ \D0BCPLspace 0)
-
-(RPAQQ \CurrentFXP 0)
-
-(RPAQQ \ResetFXP 1)
-
-(RPAQQ \SubovFXP 2)
-
-(RPAQQ \KbdFXP 3)
-
-(RPAQQ \HardReturnFXP 4)
-
-(RPAQQ \GCFXP 5)
-
-(RPAQQ \FAULTFXP 6)
-
-(RPAQQ \MiscFXP 16Q)
-
-(RPAQQ \TeleRaidFXP 30Q)
-
-(RPAQQ DCB.EM 420Q)
-
-(RPAQQ DISPINTERRUPT.EM 421Q)
-
-(RPAQQ CURSORBITMAP.EM 431Q)
-
-(RPAQQ KBDAD0.EM 177034Q)
-
-(RPAQQ KBDAD1.EM 177035Q)
-
-(RPAQQ KBDAD2.EM 177036Q)
-
-(RPAQQ KBDAD3.EM 177037Q)
-
-(RPAQQ UTILIN.EM 177030Q)
-
-(RPAQQ CURSORX.EM 426Q)
-
-(RPAQQ CURSORY.EM 427Q)
-
-(RPAQQ MOUSEX.EM 424Q)
-
-(RPAQQ MOUSEY.EM 425Q)
-
-(RPAQQ \LispKeyMask 20000Q)
-
-(RPAQQ \BcplKeyMask 10400Q)
-
-(RPAQQ \MAIKO 3)
-
-(RPAQQ \DOLPHIN 4)
-
-(RPAQQ \DORADO 5)
-
-(RPAQQ \DANDELION 6)
-
-(RPAQQ \DAYBREAK 10Q)
-
-(RPAQQ \VP.DISPLAY 11000Q)
-
-(RPAQQ \NP.DISPLAY 312Q)
-
-(RPAQQ \NP.WIDEDOVEDISPLAY 363Q)
-
-(RPAQQ \WIDEDOVEDISPLAYWIDTH 2200Q)
-
-(RPAQQ \RP.AFTERDISPLAY 316Q)
-
-(RPAQQ \RP.AFTERDOVEDISPLAY 363Q)
-
-(RPAQQ \RP.DISPLAY 0)
-
-(RPAQQ \RP.TEMPDISPLAY 5001Q)
-
-(RPAQQ \RP.MISCLOCKED 5364Q)
-
-(RPAQQ \RP.STACK 1400Q)
-
-(RPAQQ \VP.STACK 400Q)
-
-(RPAQQ \RP.MAP 400Q)
-
-(RPAQQ \NP.MAP 400Q)
-
-(RPAQQ \RP.IOPAGE 1000Q)
-
-(RPAQQ \RP.DOVEIOCBPAGE 1037Q)
-
-(RPAQQ \RP.DOVEIORGN 1040Q)
-
-(RPAQQ \VP.DOVEIORGN 100Q)
-
-(RPAQQ \DOVEIORGNSIZE 100Q)
-
-(RPAQQ \VP.IOPAGE 377Q)
-
-(RPAQQ \VP.IFPAGE 12000Q)
-
-(RPAQQ \VP.FPTOVP 1000Q)
-
-(RPAQQ \NP.FPTOVP 10000Q)
-
-(RPAQQ \RP.FPTOVP 2000Q)
-
-(RPAQQ \RP.STARTBUFFERS 1200Q)
-
-(RPAQQ \VP.TYPETABLE 14000Q)
-
-(RPAQQ \NP.TYPETABLE 2000Q)
-
-(RPAQQ \RP.TYPETABLE 12000Q)
-
-(RPAQQ \VP.GCTABLE 13000Q)
-
-(RPAQQ \NP.GCTABLE 400Q)
-
-(RPAQQ \RP.GCTABLE 14000Q)
-
-(RPAQQ \VP.GCOVERFLOW 13400Q)
-
-(RPAQQ \NP.GCOVERFLOW 1)
-
-(RPAQQ \RP.GCOVERFLOW 14400Q)
-
-(RPAQQ \FP.IFPAGE 2)
-
-(RPAQQ \VP.IOCBS 1)
-
-(RPAQQ \VP.PRIMARYMAP 12002Q)
-
-(RPAQQ \VP.SECONDARYMAP 2400Q)
-
-(RPAQQ \VP.LPT 12160Q)
-
-(RPAQQ \VP.INITSCRATCH 10Q)
-
-(RPAQQ \VP.RPT 200Q)
-
-(RPAQQ \VP.BUFFERS 332Q)
-
-(RPAQQ \DL.PROCESSORBUSY 100000Q)
-
-(RPAQQ \DL.SETTOD 100001Q)
-
-(RPAQQ \DL.READTOD 100002Q)
-
-(RPAQQ \DL.READPID 100003Q)
-
-(RPAQQ \DL.BOOTBUTTON 100004Q)
-
-
-(CONSTANTS (CDRCODING 1)
-       (\SMALLP 1)
-       (\FIXP 2)
-       (\FLOATP 3)
-       (\LITATOM 4)
-       (\LISTP 5)
-       (\ARRAYP 6)
-       (\STRINGP 7)
-       (\STACKP 10Q)
-       (\CHARACTERP 11Q)
-       (\VMEMPAGEP 12Q)
-       (\STREAM 13Q)
-       (\TT.TYPEMASK 3777Q)
-       (\TT.NOREF 100000Q)
-       (\TT.SYMBOLP 40000Q)
-       (\TT.FIXP 20000Q)
-       (\TT.NUMBERP 10000Q)
-       (\TT.ATOM 4000Q)
-       (\PMblockSize 40Q)
-       (\STATSsize 10Q)
-       (\NumPMTpages 10Q)
-       (\EmptyPMTEntry 177777Q)
-       (\FirstVmemBlock 2)
-       (\MAXVMPAGE 377775Q)
-       (\MAXVMSEGMENT 377Q)
-       (\IFPValidKey 12743Q)
-       (\FirstMDSPage 77776Q)
-       (\MaxMDSPage 1777775Q)
-       (\DefaultSecondMDSPage 177774Q)
-       (\MDSIncrement 1000Q)
-       (\PagesPerMDSUnit 2)
-       (\FirstArraySegment 56Q)
-       (\FirstArrayPage 27000Q)
-       (\DefaultSecondArrayPage 100000Q)
-       (\StackMask 160000Q)
-       (\FxtnBlock 140000Q)
-       (\GuardBlock 160000Q)
-       (\BFBlock 100000Q)
-       (\FreeStackBlock 120000Q)
-       (\NotStackBlock 0)
-       (\MinExtraStackWords 40Q)
-       (ERASECHARCODE 0)
-       (\HT1CNT 2000Q)
-       (\HTSTKBIT 1000Q)
-       (\HTCNTMASK 176000Q)
-       (\HTMAINSIZE 200000Q)
-       (\HTCOLLSIZE 4000000Q)
-       (\HTENDFREE 1)
-       (\HTFREEPTR 0)
-       (\AtomHI 0)
-       (\CHARHI 7)
-       (\AtomHTpages 400Q)
-       (\LastAtomPage 377Q)
-       (\MaxAtomFrLst 177777Q)
-       (\SmallPosHi 16Q)
-       (\SmallNegHi 17Q)
-       (\NumSmallPages 1000Q)
-       (\PNAME.HI 10Q)
-       (\ATOM.HI 54Q)
-       (\DEF.HI 12Q)
-       (\VAL.HI 14Q)
-       (\PLIST.HI 2)
-       (\NumPageMapPages 400Q)
-       (\MDSTTsize 2000Q)
-       (\UFNTableSize 2)
-       (\DTDSize 22Q)
-       (\EndTypeNumber 3777Q)
-       (\NumLPTPages 20Q)
-       (\GuardStackAddr 170000Q)
-       (\LastStackAddr 177776Q)
-       (\STACKHI 1)
-       (\HTMAINnpages 400Q)
-       (\D1BCPLspace 0)
-       (\D0BCPLspace 0)
-       (\CurrentFXP 0)
-       (\ResetFXP 1)
-       (\SubovFXP 2)
-       (\KbdFXP 3)
-       (\HardReturnFXP 4)
-       (\GCFXP 5)
-       (\FAULTFXP 6)
-       (\MiscFXP 16Q)
-       (\TeleRaidFXP 30Q)
-       (DCB.EM 420Q)
-       (DISPINTERRUPT.EM 421Q)
-       (CURSORBITMAP.EM 431Q)
-       (KBDAD0.EM 177034Q)
-       (KBDAD1.EM 177035Q)
-       (KBDAD2.EM 177036Q)
-       (KBDAD3.EM 177037Q)
-       (UTILIN.EM 177030Q)
-       (CURSORX.EM 426Q)
-       (CURSORY.EM 427Q)
-       (MOUSEX.EM 424Q)
-       (MOUSEY.EM 425Q)
-       (\LispKeyMask 20000Q)
-       (\BcplKeyMask 10400Q)
-       (\MAIKO 3)
-       (\DOLPHIN 4)
-       (\DORADO 5)
-       (\DANDELION 6)
-       (\DAYBREAK 10Q)
-       (\VP.DISPLAY 11000Q)
-       (\NP.DISPLAY 312Q)
-       (\NP.WIDEDOVEDISPLAY 363Q)
-       (\WIDEDOVEDISPLAYWIDTH 2200Q)
-       (\RP.AFTERDISPLAY 316Q)
-       (\RP.AFTERDOVEDISPLAY 363Q)
-       (\RP.DISPLAY 0)
-       (\RP.TEMPDISPLAY 5001Q)
-       (\RP.MISCLOCKED 5364Q)
-       (\RP.STACK 1400Q)
-       (\VP.STACK 400Q)
-       (\RP.MAP 400Q)
-       (\NP.MAP 400Q)
-       (\RP.IOPAGE 1000Q)
-       (\RP.DOVEIOCBPAGE 1037Q)
-       (\RP.DOVEIORGN 1040Q)
-       (\VP.DOVEIORGN 100Q)
-       (\DOVEIORGNSIZE 100Q)
-       (\VP.IOPAGE 377Q)
-       (\VP.IFPAGE 12000Q)
-       (\VP.FPTOVP 1000Q)
-       (\NP.FPTOVP 10000Q)
-       (\RP.FPTOVP 2000Q)
-       (\RP.STARTBUFFERS 1200Q)
-       (\VP.TYPETABLE 14000Q)
-       (\NP.TYPETABLE 2000Q)
-       (\RP.TYPETABLE 12000Q)
-       (\VP.GCTABLE 13000Q)
-       (\NP.GCTABLE 400Q)
-       (\RP.GCTABLE 14000Q)
-       (\VP.GCOVERFLOW 13400Q)
-       (\NP.GCOVERFLOW 1)
-       (\RP.GCOVERFLOW 14400Q)
-       (\FP.IFPAGE 2)
-       (\VP.IOCBS 1)
-       (\VP.PRIMARYMAP 12002Q)
-       (\VP.SECONDARYMAP 2400Q)
-       (\VP.LPT 12160Q)
-       (\VP.INITSCRATCH 10Q)
-       (\VP.RPT 200Q)
-       (\VP.BUFFERS 332Q)
-       (\DL.PROCESSORBUSY 100000Q)
-       (\DL.SETTOD 100001Q)
-       (\DL.READTOD 100002Q)
-       (\DL.READPID 100003Q)
-       (\DL.BOOTBUTTON 100004Q))
-)
-
-(RPAQQ \MPERRORS ((\MP.OBSOLETEVMEM 1)
-                      (\MP.INVALIDVMEM 2 "Vmem inconsistent at startup")
-                      (\MP.IOCBPAGE 3 "No place for IOCB page at startup")
-                      (\MP.MOB 4 "Map out of bounds")
-                      (\MP.INVALIDADDR 5)
-                      (\MP.INVALIDVP 6)
-                      (\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain")
-                      (\MP.SELECTLOOP 10Q "Loop in \SELECTREALPAGE")
-                      (\MP.NEWPAGE 11Q "Attempt to allocate already existing page")
-                      (\MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page")
-                      (\MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another")
-                      (\MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box")
-                      (\MP.RESIDENT 15Q "Fault on resident page")
-                      (\MP.STACKFAULT 16Q "Fault on stack")
-                      (\MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)")
-                      (\MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T")
-                      (\MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code")
-                      (\MP.STACKFULL 23Q)
-                      (\MP.MDSFULL 24Q)
-                      (\MP.UNKNOWN.UFN 25Q)
-                      (\MP.ATOMSFULL 26Q)
-                      (\MP.PNAMESFULL 27Q)
-                      (\MP.USECOUNTOVERFLOW 30Q)
-                      (\MP.MDSFULLWARNING 31Q)
-                      (\MP.BADMDSFREELIST 32Q)
-                      (\MP.BADARRAYBLOCK 33Q)
-                      (\MP.BADDELETEBLOCK 34Q)
-                      (\MP.BADARRAYRECLAIM 35Q)
-                      (\MP.BIGREFCNTMISSING 36Q 
-                             "PTR refcnt previously overflowed, but not found in table.")
-                      (\MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table")
-                      (\MP.DELREF0 40Q)
-                      (\MP.PROCERROR 41Q)
-                      (\MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use")
-                      (\MP.32MBINUSE 43Q)
-                      (\MP.TOPUNWOUND 44Q "Unexpected (RETTO T)")
-                      (\MP.STACKRELEASED 45Q)
-                      (\MP.FLUSHLOCKED 46Q)
-                      (\MP.MAPNOTLOCKED 47Q)
-                      (\MP.UNLOCKINGMAP 50Q)
-                      (\MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper")
-                      (\MP.BADRUNTABLE 52Q "Malformed run table for vmem file")))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \MP.OBSOLETEVMEM 1)
-
-(RPAQ \MP.INVALIDVMEM 2 "Vmem inconsistent at startup")
-
-(RPAQ \MP.IOCBPAGE 3 "No place for IOCB page at startup")
-
-(RPAQ \MP.MOB 4 "Map out of bounds")
-
-(RPAQQ \MP.INVALIDADDR 5)
-
-(RPAQQ \MP.INVALIDVP 6)
-
-(RPAQ \MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain")
-
-(RPAQ \MP.SELECTLOOP 10Q "Loop in \SELECTREALPAGE")
-
-(RPAQ \MP.NEWPAGE 11Q "Attempt to allocate already existing page")
-
-(RPAQ \MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page")
-
-(RPAQ \MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another")
-
-(RPAQ \MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box")
-
-(RPAQ \MP.RESIDENT 15Q "Fault on resident page")
-
-(RPAQ \MP.STACKFAULT 16Q "Fault on stack")
-
-(RPAQ \MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)")
-
-(RPAQ \MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T")
-
-(RPAQ \MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code")
-
-(RPAQQ \MP.STACKFULL 23Q)
-
-(RPAQQ \MP.MDSFULL 24Q)
-
-(RPAQQ \MP.UNKNOWN.UFN 25Q)
-
-(RPAQQ \MP.ATOMSFULL 26Q)
-
-(RPAQQ \MP.PNAMESFULL 27Q)
-
-(RPAQQ \MP.USECOUNTOVERFLOW 30Q)
-
-(RPAQQ \MP.MDSFULLWARNING 31Q)
-
-(RPAQQ \MP.BADMDSFREELIST 32Q)
-
-(RPAQQ \MP.BADARRAYBLOCK 33Q)
-
-(RPAQQ \MP.BADDELETEBLOCK 34Q)
-
-(RPAQQ \MP.BADARRAYRECLAIM 35Q)
-
-(RPAQ \MP.BIGREFCNTMISSING 36Q "PTR refcnt previously overflowed, but not found in table.")
-
-(RPAQ \MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table")
-
-(RPAQQ \MP.DELREF0 40Q)
-
-(RPAQQ \MP.PROCERROR 41Q)
-
-(RPAQ \MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use")
-
-(RPAQQ \MP.32MBINUSE 43Q)
-
-(RPAQ \MP.TOPUNWOUND 44Q "Unexpected (RETTO T)")
-
-(RPAQQ \MP.STACKRELEASED 45Q)
-
-(RPAQQ \MP.FLUSHLOCKED 46Q)
-
-(RPAQQ \MP.MAPNOTLOCKED 47Q)
-
-(RPAQQ \MP.UNLOCKINGMAP 50Q)
-
-(RPAQ \MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper")
-
-(RPAQ \MP.BADRUNTABLE 52Q "Malformed run table for vmem file")
-
-
-(CONSTANTS (\MP.OBSOLETEVMEM 1)
-       (\MP.INVALIDVMEM 2 "Vmem inconsistent at startup")
-       (\MP.IOCBPAGE 3 "No place for IOCB page at startup")
-       (\MP.MOB 4 "Map out of bounds")
-       (\MP.INVALIDADDR 5)
-       (\MP.INVALIDVP 6)
-       (\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain")
-       (\MP.SELECTLOOP 10Q "Loop in \SELECTREALPAGE")
-       (\MP.NEWPAGE 11Q "Attempt to allocate already existing page")
-       (\MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page")
-       (\MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another")
-       (\MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box")
-       (\MP.RESIDENT 15Q "Fault on resident page")
-       (\MP.STACKFAULT 16Q "Fault on stack")
-       (\MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)")
-       (\MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T")
-       (\MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code")
-       (\MP.STACKFULL 23Q)
-       (\MP.MDSFULL 24Q)
-       (\MP.UNKNOWN.UFN 25Q)
-       (\MP.ATOMSFULL 26Q)
-       (\MP.PNAMESFULL 27Q)
-       (\MP.USECOUNTOVERFLOW 30Q)
-       (\MP.MDSFULLWARNING 31Q)
-       (\MP.BADMDSFREELIST 32Q)
-       (\MP.BADARRAYBLOCK 33Q)
-       (\MP.BADDELETEBLOCK 34Q)
-       (\MP.BADARRAYRECLAIM 35Q)
-       (\MP.BIGREFCNTMISSING 36Q "PTR refcnt previously overflowed, but not found in table.")
-       (\MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table")
-       (\MP.DELREF0 40Q)
-       (\MP.PROCERROR 41Q)
-       (\MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use")
-       (\MP.32MBINUSE 43Q)
-       (\MP.TOPUNWOUND 44Q "Unexpected (RETTO T)")
-       (\MP.STACKRELEASED 45Q)
-       (\MP.FLUSHLOCKED 46Q)
-       (\MP.MAPNOTLOCKED 47Q)
-       (\MP.UNLOCKINGMAP 50Q)
-       (\MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper")
-       (\MP.BADRUNTABLE 52Q "Malformed run table for vmem file"))
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \ARRAYSPACE \ARRAYSPACE2 \ATOMSPACE \AtomHashTable \SMALLPOSPSPACE \SMALLNEGSPACE 
-       \PNPSPACE \OLDATOMSPACE \DEFSPACE \VALSPACE \PLISTSPACE \PAGEMAP \PageMapTBL \InterfacePage 
-       \IOPAGE \DoveIORegion \IOCBPAGE \FPTOVP \MDSTypeTable \MISCSTATS \UFNTable \DTDSpaceBase 
-       \LISTPDTD \LOCKEDPAGETABLE \STACKSPACE \HTMAIN \HTOVERFLOW \HTBIGCOUNT \HTCOLL \DISPLAYREGION)
-)
-
-(BLOCKRECORD MISCSTATS ((STARTTIME FIXP)
-                        (TOTALTIME FIXP)
-                        (SWAPWAITTIME FIXP)
-                        (PAGEFAULTS FIXP)
-                        (SWAPWRITES FIXP)
-                        (DISKIOTIME FIXP)
-                        (DISKOPS FIXP)
-                        (KEYBOARDWAITTIME FIXP)
-                        (GCTIME FIXP)
-                        (NETIOTIME FIXP)
-                        (NETIOOPS FIXP)
-                        (SWAPTEMP0 FIXP)
-                        (SWAPTEMP1 FIXP)
-                        (RCLKSECOND FIXP)
-                        (SECONDSCLOCK FIXP)
-                        (MILLISECONDSCLOCK FIXP)
-                        (BASECLOCK FIXP)
-                        (RCLKTEMP0 FIXP)
-                        (SECONDSTMP FIXP)
-                        (MILLISECONDSTMP FIXP)
-                        (BASETMP FIXP)
-                        (EXCESSTIMETMP FIXP)
-                        (CLOCKTEMP0 FIXP)
-                        (DISKTEMP0 FIXP)
-                        (DISKTEMP1 FIXP)
-                        (TELERAIDTEMP1 FIXP)
-                        (TELERAIDTEMP2 FIXP)
-                        (TELERAIDTEMP3 FIXP)
-                        (LASTUSERACTION FIXP)
-                        (DLMOUSETIMER FIXP)
-                        (DLMOUSETEMP FIXP))
-       (CREATE (\ALLOCBLOCK 37Q)))
-
-(BLOCKRECORD IFPAGE ((CurrentFXP WORD)                       (* ; 
-                                      "First 7 items are FX values for user and 6 system contexts.")
-                     (ResetFXP WORD)
-                     (SubovFXP WORD)
-                     (KbdFXP WORD)
-                     (HardReturnFXP WORD)
-                     (GCFXP WORD)
-                     (FAULTFXP WORD)
-                     (EndOfStack WORD)                       (* ; 
-                            "Stack high-water mark: address of guard block at current end of stack")
-                     (LVersion WORD)                         (* ; 
-           "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp")
-                     (MinRVersion WORD)
-                     (MinBVersion WORD)
-                     (RVersion WORD)                         (* ; 
-                                               "Bcpl fills in the actual microcode, Bcpl versions.")
-                     (BVersion WORD)
-                     (MachineType WORD)
-                     (MiscFXP WORD)                          (* ; "FX for MISC context")
-                     (Key WORD)                              (* ; 
-                                                           "= IFPValidKey if vmem consistent.")
-                     (SerialNumber WORD)                     (* ; 
-                                                           "Pup host number (Dorado/Dolphin)")
-                     (EmulatorSpace WORD)                    (* ; 
-                                                           "Hiloc of bcpl space (always zero now)")
-                     (ScreenWidth WORD)
-                     (NxtPMAddr WORD)                        (* ; 
-                                            "Next page to be allocated in secondary page map table")
-                     (NIL WORD)                              (* ; 
-                                                          "WAS NActivePages, Length of vmem in use")
-                     (NIL WORD)                              (* ; 
-                                      "WAS NDirtyPages, not used, but maintained as = NActivePages")
-                     (filePnPMP0 WORD)                       (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live")
-                     (filePnPMT0 WORD)                       (* ; 
-                                       "Sysout page number of first page of primary page map table")
-                     (TELERAIDFXP WORD)                      (* ; "FX for TeleRaid server context")
-                     (NATIVE-START-MEM-PAGE WORD)            (* ; 
-                                                           "Unix page where native code starts")
-                     (NATIVE-LENGTH-PAGE WORD)               (* ; "Unix page length of native code")
-                     (NATIVE-PAGE-OFFSET WORD)               (* ; 
-                                                           "Lisp Disk Page offset  of native code")
-                     (UserNameAddr WORD)                     (* ; 
-                                 "Addresses in bcpl space (seg 0) of global user name and password")
-                     (UserPswdAddr WORD)
-                     (StackBase WORD)                        (* ; 
-                                                           "Stack address where user stack starts")
-                     (FAULTHI WORD)                          (* ; 
-         "Microcode for page fault stores fault address here, then does context switch to FAULTFXP")
-                     (FAULTLO WORD)
-                     (DEVCONFIG WORD)                        (* ; "IT'S FOR KB,DISP TYPE")
-                                                             (* ; 
-                                   "Formerly REALPAGETABLE, back when it was always in Bcpl space.")
-                     (RPTSIZE WORD)                          (* ; 
-                                                           "Number of entries in Real Page Table")
-                     (RPOFFSET WORD)                         (* ; "RP-RPOFFSET => index in table")
-                     (MAXETHERBYTES WORD)                    (* ; 
-                          "Number of bytes available in a pbi, not counting encapsulation (Dorado)")
-                     (EMBUFVP WORD)                          (* ; 
-                                                           "VP of a one-page emulator buffer")
-                     (NSHost0 WORD)                          (* ; "Machine's 48-bit NS host number.  Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in.")
-                     (NSHost1 WORD)
-                     (NSHost2 WORD)
-                     (MDSZone WORD)                          (* ; 
-                                               "Obsolete -- was used by Dolphin 10MB network code.")
-                     (MDSZoneLength WORD)
-                     (EMUBUFFERS WORD)                       (* ; 
-                                             "Buffer space in segment 0 for swapping/disk activity")
-                     (EMUBUFLENGTH WORD)                     (* ; "Number of words of said space")
-
-                     (* ;; "The following 2 are available if NEW_STOARGE is specified in C")
-
-                     (ProcessSize WORD)                      (* ; 
-                                                  "Process size for which can be use as LISP space")
-                     (StorageFullState WORD)                 (* ; "Save last storage state")
-                     (ISFMAP WORD)
-
-                     (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!")
-
-                     (MISCSTACKFN FULLXPOINTER)
-                     (MISCSTACKARG1 FULLXPOINTER)
-                     (MISCSTACKARG2 FULLXPOINTER)
-                     (MISCSTACKRESULT FULLXPOINTER)
-                     (NRealPages WORD)                       (* ; "Number pages of real memory")
-                     (LastLockedFilePage WORD)               (* ; 
-                         "Last page of vmem that is locked--booting has to load at least that far.")
-                     (LastDominoFilePage WORD)               (* ; 
-                                                "Last sysout page reserved for Dandelion microcode")
-                     (FPTOVPStart WORD)                      (* ; "Sysout page where FPTOVP starts")
-                     (FAKEMOUSEBITS WORD)                    (* ; 
-                                      "Used to implement fake middle button on 2-button Dandelion.")
-                     (DL24BitAddressable WORD)               (* ; 
-                                      "non-zero if DLion capable of addressing 32MB virtual memory")
-                     (REALPAGETABLEPTR FULLXPOINTER)         (* ; 
-                            "Address of real page table, set up by Bcpl (but not chained together)")
-                     (SYSDISK WORD)                          (* ; 
-                       "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.")
-                     (FullSpaceUsed WORD)                    (* ; 
-                                          "Non-zero if vmem beyond initial 8MB has been allocated.")
-                     (FAKEKBDAD4 WORD)
-                     (FAKEKBDAD5 WORD)
-
-                     (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with.")
-
-                     (XVmemFmapBase WORD)                    (* ; 
- "Bcpl stores isf map pointer to each partition here.  First is redundant with ISFMAP field above.")
-                     (NIL WORD)
-                     (NIL WORD)
-                     (XVmemFmapHighBase WORD)                (* ; 
-                          "Bcpl stores the highest vm page contained in this or earlier partition.")
-                     (NIL WORD)
-                     (NIL WORD)
-                     (XVmemDiskBase FULLXPOINTER)            (* ; 
-      "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).")
-                     (NIL FULLXPOINTER)
-                     (NIL FULLXPOINTER)
-                     (DLLastVmemPage FIXP)                   (* ; 
-                                           "DLion booting microcode puts length of vmem file here.")
-                     (NActivePages FIXP)                     (* ; "Length of vmem in use")
-                     (NDirtyPages FIXP)                      (* ; 
-                                                       "not used, but maintained as = NActivePages")
-                     )
-       (CREATE (\ALLOCBLOCK 53Q)))
-
-(BLOCKRECORD IOPAGE ((NIL 22Q WORD)
-                     (DLMAINTPANEL WORD)
-                     (DLFLOPPYCMD WORD)
-                     (DLTTYPORTCMD WORD)
-                     (DLPROCESSORCMD WORD)
-                     (NEWMOUSESTATE WORD)
-                     (DLBEEPCMD WORD)
-                     (DLRS232CMISCCOMMAND WORD)
-                     (DLRS232CPUTFLAG WORD)
-                     (DLRS232CGETFLAG WORD)
-                     (NIL 6 WORD)
-                     (DLFLOPPY WORD)
-                     (DLTTYOUT WORD)
-                     (NIL 1 WORD)
-                     (DLTTYIN WORD)
-                     (NIL 1 WORD)
-                     (DLPROCESSOR2 WORD)
-                     (DLPROCESSOR1 WORD)
-                     (DLPROCESSOR0 WORD)
-                     (NEWMOUSEX WORD)
-                     (NEWMOUSEY WORD)
-                     (DLBEEPFREQ WORD)
-                     (DLRS232CPARAMETERCSBLO WORD)
-                     (DLRS232CPARAMETERCSBHI WORD)
-                     (DLRS232CSETRS366STATUS 3 WORD)
-                     (DLRS232CPUTCSBLO WORD)
-                     (DLRS232CPUTCSBHI WORD)
-                     (DLRS232CGETCSBLO WORD)
-                     (DLRS232CGETCSBHI WORD)
-                     (DLRS232CDEVICESTATUS WORD)
-                     (DLRS232CPARAMETEROUTCOME WORD)
-                     (DLTODVALID WORD)
-                     (DLTODLO WORD)
-                     (DLTODHI WORD)
-                     (DLTODLO2 WORD)
-                     (DLMOUSEX WORD)
-                     (DLMOUSEY WORD)
-                     (DLUTILIN WORD)
-                     (DLKBDAD0 WORD)
-                     (DLKBDAD1 WORD)
-                     (DLKBDAD2 WORD)
-                     (DLKBDAD3 WORD)
-                     (DLKBDAD4 WORD)
-                     (DLKBDAD5 WORD)
-                     (DLLSEPIMAGECSB 40Q WORD)
-                     (DLIOPHARDWARECONFIG WORD)
-                     (NIL 13Q WORD)
-                     (DLRS232CPARAMETERCSBLO.11 WORD)
-                     (DLRS232CPARAMETERCSBHI.11 WORD)
-                     (DLRS232CSETRS366STATUS.11 16Q WORD)
-                     (NIL 74Q WORD)
-                     (DLMAGTAPE 4 WORD)
-                     (DLETHERNET 14Q WORD)
-                     (NIL 37Q WORD)
-                     (DLDISPINTERRUPT WORD)
-                     (DLDISPCONTROL WORD)
-                     (DLDISPBORDER WORD)
-                     (DLCURSORX WORD)
-                     (DLCURSORY WORD)
-                     (DLCURSORBITMAP 20Q WORD))
-       [ACCESSFNS IOPAGE ((DLCURSORBITMAPPTR (\ADDBASE DATUM 360Q))
-                          (DLCURSORYPTR (\ADDBASE DATUM 357Q))
-                          (DLCURSORXPTR (\ADDBASE DATUM 356Q))
-                          (DLDISPINTERRUPTPTR (\ADDBASE DATUM 353Q))
-                          (DLETHERNETPTR (\ADDBASE DATUM 300Q))
-                          (DLKBDAD5PTR (\ADDBASE DATUM 103Q))
-                          (DLKBDAD4PTR (\ADDBASE DATUM 102Q))
-                          (DLKBDAD3PTR (\ADDBASE DATUM 101Q))
-                          (DLKBDAD2PTR (\ADDBASE DATUM 100Q))
-                          (DLKBDAD1PTR (\ADDBASE DATUM 77Q))
-                          (DLKBDAD0PTR (\ADDBASE DATUM 76Q))
-                          (DLUTILINPTR (\ADDBASE DATUM 75Q))
-                          (DLMOUSEYPTR (\ADDBASE DATUM 74Q))
-                          (DLMOUSEXPTR (\ADDBASE DATUM 73Q))
-                          (DLTODLOPTR (\ADDBASE DATUM 70Q))
-                          (DLMAINTPANELPTR (\ADDBASE DATUM 22Q]
-       (CREATE (\ALLOCBLOCK 200Q)))
-(DECLARE%: EVAL@COMPILE 
-
-[PUTPROPS EMADDRESS MACRO (ARGS ([LAMBDA (ADDR)
-                                   (COND
-                                      [(EQ \D1BCPLspace \D0BCPLspace)
-                                       (LIST (BIG-VMEM-CODE (LIST 'OPCODES 'GCONST 0 0
-                                                                  (LRSH ADDR 10Q)
-                                                                  (LOGAND ADDR 377Q))
-                                                    (LIST 'OPCODES 'GCONST 0 (LRSH ADDR 10Q)
-                                                          (LOGAND ADDR 377Q]
-                                      (T `(\VAG2 (fetch EmulatorSpace of \InterfacePage)
-                                                 %, ADDR]
-                                 (EVAL (CAR ARGS]
-
-(PUTPROPS EMGETBASE MACRO ((OFFSET)
-                           (\GETBASE (EMADDRESS OFFSET)
-                                  0)))
-
-(PUTPROPS EMPUTBASE MACRO ((OFFSET VAL)
-                           (\PUTBASE (EMADDRESS OFFSET)
-                                  0 VAL)))
-
-(PUTPROPS EMULATORSEGMENT MACRO (NIL (fetch EmulatorSpace of \InterfacePage)))
-
-[PUTPROPS EMPOINTER MACRO (X (COND
-                                ((NEQ \D1BCPLspace \D0BCPLspace)
-                                 (LIST '\VAG2 '(fetch (IFPAGE EmulatorSpace) of 
-                                                                                       \InterfacePage
-                                                      )
-                                       (CAR X)))
-                                ((ZEROP (CAR X))
-                                 NIL)
-                                (T (LIST '\VAG2 \D0BCPLspace (CAR X]
-
-[PUTPROPS EMADDRESSP MACRO (X (LIST 'EQ (LIST '\HILOC (CAR X))
-                                    (COND
-                                       ((EQ \D1BCPLspace \D0BCPLspace)
-                                        \D0BCPLspace)
-                                       (T '(fetch (IFPAGE EmulatorSpace) of \InterfacePage]
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-)
-
-(PUTPROPS LLPARAMS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10Q))
-(PUTPROPS LLPARAMS COPYRIGHT (
-"Syntelligence Systems, Inc.  This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc.  Reverse engineering, reverse compiling and disassembling of object code are prohibited.  Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc.  Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets"
- 3675Q 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 3706Q 3707Q 3710Q 3712Q 3716Q))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (7177Q 13221Q (MAKERECORD 7211Q . 13217Q)))))
-STOP
