diff --git a/.gitignore b/.gitignore
index c43f9967..f0b27cf7 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,7 @@
+# loadup interim steps
+
+tmp/*
+loadups/init*
 
 #compiled code -- leave in for now
 
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/library/EXPORTS.ALL b/library/EXPORTS.ALL
index 18697a89..9fd11fac 100644
--- a/library/EXPORTS.ALL
+++ b/library/EXPORTS.ALL
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(LISPXPRIN1 "EXPORTS GATHERED FROM {DSK}<home>larry>ilisp>medley>sources> ON 16-Jan-2021 22:50:43"  T)
(LISPXTERPRI T)
(PUTPROP (QUOTE FILESETS) (QUOTE IMPORTDATE) (IDATE "29-Jan-1998 16:26:53"))

(RPAQQ MODARITHMACROS (CEIL FLOOR FOLDHI FOLDLO MODUP UNFOLD MOD))
(PUTPROPS CEIL MACRO ((X N) (FLOOR (IPLUS X (CONSTANT (SUB1 N))) N)))
(PUTPROPS FLOOR MACRO ((X N) (LOGAND X (CONSTANT (LOGXOR (SUB1 N) -1)))))
(PUTPROPS FOLDHI MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR (
AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) (LIST (QUOTE 
IPLUS) FORM (SUB1 DIVISOR)) (SUB1 (INTEGERLENGTH DIVISOR)))))))
(PUTPROPS FOLDLO MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR (
AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) FORM (SUB1 (
INTEGERLENGTH DIVISOR)))))))
(PUTPROPS MODUP MACRO (OPENLAMBDA (X N) (IDIFFERENCE (SUB1 N) (IMOD (SUB1 X) N))))
(PUTPROPS UNFOLD MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR (
AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LLSH) FORM (SUB1 (
INTEGERLENGTH DIVISOR)))))))
(PUTPROPS MOD MACRO (= . IMOD))
(RPAQQ BITSPERNIBBLE 4)
(RPAQQ NIBBLESPERBYTE 2)
(RPAQQ BITSPERBYTE 8)
(RPAQQ BITSPERCELL 32)
(RPAQQ BITSPERWORD 16)
(RPAQQ BYTESPERCELL 4)
(RPAQQ BYTESPERPAGE 512)
(RPAQQ BYTESPERWORD 2)
(RPAQQ CELLSPERPAGE 128)
(RPAQQ CELLSPERSEGMENT 32768)
(RPAQQ PAGESPERSEGMENT 256)
(RPAQQ WORDSPERCELL 2)
(RPAQQ WORDSPERPAGE 256)
(RPAQQ WORDSPERSEGMENT 65536)
(RPAQQ WORDSPERQUAD 4)
(RPAQQ CELLSPERQUAD 2)
(RPAQQ BYTESPERQUAD 8)
(CONSTANTS BITSPERNIBBLE NIBBLESPERBYTE BITSPERBYTE BITSPERCELL BITSPERWORD BYTESPERCELL BYTESPERPAGE 
BYTESPERWORD CELLSPERPAGE CELLSPERSEGMENT PAGESPERSEGMENT WORDSPERCELL WORDSPERPAGE WORDSPERSEGMENT 
WORDSPERQUAD CELLSPERQUAD BYTESPERQUAD)
(RPAQQ INTEGERSIZECONSTANTS ((BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP
)) (MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP (
IDIFFERENCE -1 MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP (
LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 
MAX.FIXP))))
(RPAQ BITS.PER.SMALLP (ADD1 BITSPERWORD))
(RPAQ SMALLP.LENGTH (SUB1 BITS.PER.SMALLP))
(RPAQ MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH)))))
(RPAQ MIN.SMALLP (IDIFFERENCE -1 MAX.SMALLP))
(RPAQ BITS.PER.FIXP BITSPERCELL)
(RPAQ FIXP.LENGTH (SUB1 BITS.PER.FIXP))
(RPAQ MAX.FIXP (LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH)))))
(RPAQ MIN.FIXP (IDIFFERENCE -1 MAX.FIXP))
(CONSTANTS (BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP)) (MAX.SMALLP (
LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP (IDIFFERENCE -1 
MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP (LOGOR (LSH 1 (
SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 MAX.FIXP)))
(PUTPROP (QUOTE MODARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:46:21"))

(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 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10 
NIL |VMemPagePType|) (\\STREAM 11 NIL STREAMTYPE) (* |;;| 
"TYPE TABLE CONSTANTS - - - - - - - - - - - - - - - - - - - - - -") (\\TT.TYPEMASK 2047 |TTTypeMask| T
) (\\TT.NOREF 32768 NIL T) (\\TT.SYMBOLP 16384 NIL T) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 
2048) (* |;;| "page map - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -") 
(|\\PMblockSize| 32 PMBLOCKSIZE) (|\\STATSsize| 8 T) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535 T) (
|\\FirstVmemBlock| 2 T) (\\MAXVMPAGE 131069) (\\MAXVMSEGMENT 255) (* |;;| "interface page") (
|\\IFPValidKey| 5603 T) (* |;;| "MDS") (|\\FirstMDSPage| 16382) (|\\MaxMDSPage| 524285) (
|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512) (|\\PagesPerMDSUnit| 2) (* \; 
"(FOLDLO \\MDSIncrement WORDSPERPAGE)") (* |;;| "arrays") (\\ARRAYSPACE (46 0)) (|\\FirstArraySegment|
 46) (|\\FirstArrayPage| 11776) (\\ARRAYSPACE2 (64 0)) (|\\DefaultSecondArrayPage| 16384) (* |;;| 
"stack block constants") (|\\StackMask| 57344 T T) (|\\FxtnBlock| 49152 T T) (|\\GuardBlock| 57344 T T
) (|\\BFBlock| 32768 T T) (|\\FreeStackBlock| 40960 T T) (|\\NotStackBlock| 0) (* \; 
"none of the above") (|\\MinExtraStackWords| 32 T T) (* |;;| "backspace kludge") (ERASECHARCODE 0 T) (
* |;;| "GC constants") (\\HT1CNT 1024 NIL T) (\\HTSTKBIT 512 NIL T) (\\HTCNTMASK 64512 NIL T) (
\\HTMAINSIZE 65536 NIL T) (\\HTCOLLSIZE 1048576 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| (21 0) (|AHTspace| 
|AHTbase|)) (|\\AtomHTpages| 256 AHTSIZE) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) (
\\SMALLPOSPSPACE (14 0)) (|\\SmallPosHi| 14 |SMALLPOSspace| |smallpl|) (\\SMALLNEGSPACE (15 0)) (
|\\SmallNegHi| 15 |SMALLNEGspace| |smallneg|) (|\\NumSmallPages| 512) (* |;;| 
"PNAME SPACEin the old world; used for initial atoms now.") (\\PNPSPACE (8 0) (|PNPspace| |PNPbase|)) 
(\\PNAME.HI 8) (\\OLDATOMSPACE (44 0)) (* \; "NEW ATOM SPACE") (\\ATOM.HI 44) (* \; 
"HI PART OF NEW ATOM SPACE") (* |;;| "Definitions in old atom world") (\\DEFSPACE (10 0) (|DEFspace| 
|DEFbase|) (|DEFspace| |DEFbase|)) (\\DEF.HI 10) (\\VALSPACE (12 0) (|TOPVALspace| |TOPVALbase|) (
|VALspace| |VALbase|)) (\\VAL.HI 12) (\\PLISTSPACE (2 0) (|PLISTspace| |PLISTbase|)) (\\PLIST.HI 2) (
\\PAGEMAP (5 0) (|PAGEMAPspace| |PAGEMAPbase|)) (|\\NumPageMapPages| 256) (|\\PageMapTBL| (20 512) (
|PMTspace| |PMTbase|)) (|\\InterfacePage| (20 0) (|INTERFACEspace| |INTERFACEbase|) (|INTERFACEspace| 
|INTERFACEbase|)) (\\IOPAGE (0 65280)) (|\\DoveIORegion| (0 16384)) (\\IOCBPAGE (0 256)) (\\FPTOVP (2 
0)) (|\\MDSTypeTable| (24 0) (|MDSTYPEspace| |MDSTYPEbase|) (|MDSTYPEspace| |MDSTYPEbase|)) (
|\\MDSTTsize| 1024 T) (* \; "in Pages") (\\MISCSTATS (20 2560) (|STATSspace| |MISCSTATSbase|)) (
|\\UFNTable| (20 3072) NIL (|STATSspace| |UFNTablebase|)) (|\\UFNTableSize| 2) (|\\DTDSpaceBase| (20 
4096) (|DTDspace| |DTDbase|) (|DTDspace| |DTDbase|)) (|\\DTDSize| 18 T) (\\LISTPDTD (20 4186)) (
|\\EndTypeNumber| 2047) (\\LOCKEDPAGETABLE (20 28672)) (|\\NumLPTPages| 16) (\\STACKSPACE (1 0) (
|STACKspace| NIL) (|STACKspace| NIL)) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 
1 T T) (\\HTMAIN (22 0) (|HTMAINspace| |HTMAINbase|) (|HTMAINspace| |HTMAINbase|)) (|\\HTMAINnpages| 
256 T) (\\HTOVERFLOW (23 0) NIL (NIL |HTOVERFLOWbase|)) (\\HTBIGCOUNT (23 32768)) (\\HTCOLL (28 0) NIL
 (|HTCOLLspace| |HTCOLLbase|)) (\\DISPLAYREGION (18 0)) (|\\D1BCPLspace| 0 T |LEmubrHiVal|) (
|\\D0BCPLspace| 0 T) (* |;;| "Interface Page locations") (|\\CurrentFXP| 0 T T) (|\\ResetFXP| 1 T T) (
|\\SubovFXP| 2 T T) (|\\KbdFXP| 3 T T) (|\\HardReturnFXP| 4 T T) (\\GCFXP 5) (\\FAULTFXP 6 T T) (
|\\MiscFXP| 14 T T) (|\\TeleRaidFXP| 24 T T) (* |;;| "emulator segment locations") (DCB.EM 272) (
DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (KBDAD1.EM 65053) (KBDAD2.EM 65054) (
KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) (
|\\LispKeyMask| 8192 T T) (|\\BcplKeyMask| 4352 T T) (* \; "Machine types") (\\MAIKO 3) (\\DOLPHIN 4) 
(\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (* |;;| "FOR DLION (AND DAYBREAK)") (\\VP.DISPLAY 4608) (
\\NP.DISPLAY 202) (* \; "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)") (
\\NP.WIDEDOVEDISPLAY 243) (* \; "Wide Dove display 1152x864 pixels") (\\WIDEDOVEDISPLAYWIDTH 1152) (
\\RP.AFTERDISPLAY 206) (* \; "Includes 4 pages for cursor") (\\RP.AFTERDOVEDISPLAY 243) (* \; 
"if big screen") (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (* \; 
"(+ \\RP.TEMPDISPLAY \\NP.WIDEDOVEDISPLAY)") (\\RP.STACK 768) (\\VP.STACK 256) (\\RP.MAP 256) (
\\NP.MAP 256) (\\RP.IOPAGE 512) (* \; 
"The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range") (\\RP.DOVEIOCBPAGE 543) (
\\RP.DOVEIORGN 544) (\\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 5120) (
\\VP.FPTOVP 512) (\\NP.FPTOVP 4096) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 6144) (
\\NP.TYPETABLE 1024) (\\RP.TYPETABLE 5120) (\\VP.GCTABLE 5632) (\\NP.GCTABLE 256) (\\RP.GCTABLE 6144) 
(\\VP.GCOVERFLOW 5888) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 6400) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) (
\\VP.PRIMARYMAP 5122) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 5232) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) (
\\VP.BUFFERS 218) (* \; "DLion processor commands") (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) (
\\DL.READTOD 32770) (\\DL.READPID 32771) (\\DL.BOOTBUTTON 32772)))
(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 18 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 32 WORD) (DLIOPHARDWARECONFIG WORD)
 (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) (DLRS232CPARAMETERCSBHI.11 WORD) (
DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) (DLETHERNET 12 WORD NIL T) (NIL 31
 WORD) (DLDISPINTERRUPT WORD NIL T) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) (DLCURSORX WORD NIL T) (
DLCURSORY WORD NIL T) (DLCURSORBITMAP 16 WORD NIL T)))
(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 8)
(RPAQQ \\CHARACTERP 9)
(RPAQQ \\VMEMPAGEP 10)
(RPAQQ \\STREAM 11)
(RPAQQ \\TT.TYPEMASK 2047)
(RPAQQ \\TT.NOREF 32768)
(RPAQQ \\TT.SYMBOLP 16384)
(RPAQQ \\TT.FIXP 8192)
(RPAQQ \\TT.NUMBERP 4096)
(RPAQQ \\TT.ATOM 2048)
(RPAQQ |\\PMblockSize| 32)
(RPAQQ |\\STATSsize| 8)
(RPAQQ |\\NumPMTpages| 8)
(RPAQQ |\\EmptyPMTEntry| 65535)
(RPAQQ |\\FirstVmemBlock| 2)
(RPAQQ \\MAXVMPAGE 131069)
(RPAQQ \\MAXVMSEGMENT 255)
(RPAQQ |\\IFPValidKey| 5603)
(RPAQQ |\\FirstMDSPage| 16382)
(RPAQQ |\\MaxMDSPage| 524285)
(RPAQQ |\\DefaultSecondMDSPage| 65532)
(RPAQQ |\\MDSIncrement| 512)
(RPAQQ |\\PagesPerMDSUnit| 2)
(RPAQQ |\\FirstArraySegment| 46)
(RPAQQ |\\FirstArrayPage| 11776)
(RPAQQ |\\DefaultSecondArrayPage| 16384)
(RPAQQ |\\StackMask| 57344)
(RPAQQ |\\FxtnBlock| 49152)
(RPAQQ |\\GuardBlock| 57344)
(RPAQQ |\\BFBlock| 32768)
(RPAQQ |\\FreeStackBlock| 40960)
(RPAQQ |\\NotStackBlock| 0)
(RPAQQ |\\MinExtraStackWords| 32)
(RPAQQ ERASECHARCODE 0)
(RPAQQ \\HT1CNT 1024)
(RPAQQ \\HTSTKBIT 512)
(RPAQQ \\HTCNTMASK 64512)
(RPAQQ \\HTMAINSIZE 65536)
(RPAQQ \\HTCOLLSIZE 1048576)
(RPAQQ \\HTENDFREE 1)
(RPAQQ \\HTFREEPTR 0)
(RPAQQ |\\AtomHI| 0)
(RPAQQ \\CHARHI 7)
(RPAQQ |\\AtomHTpages| 256)
(RPAQQ |\\LastAtomPage| 255)
(RPAQQ |\\MaxAtomFrLst| 65535)
(RPAQQ |\\SmallPosHi| 14)
(RPAQQ |\\SmallNegHi| 15)
(RPAQQ |\\NumSmallPages| 512)
(RPAQQ \\PNAME.HI 8)
(RPAQQ \\ATOM.HI 44)
(RPAQQ \\DEF.HI 10)
(RPAQQ \\VAL.HI 12)
(RPAQQ \\PLIST.HI 2)
(RPAQQ |\\NumPageMapPages| 256)
(RPAQQ |\\MDSTTsize| 1024)
(RPAQQ |\\UFNTableSize| 2)
(RPAQQ |\\DTDSize| 18)
(RPAQQ |\\EndTypeNumber| 2047)
(RPAQQ |\\NumLPTPages| 16)
(RPAQQ |\\GuardStackAddr| 61440)
(RPAQQ |\\LastStackAddr| 65534)
(RPAQQ \\STACKHI 1)
(RPAQQ |\\HTMAINnpages| 256)
(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| 14)
(RPAQQ |\\TeleRaidFXP| 24)
(RPAQQ DCB.EM 272)
(RPAQQ DISPINTERRUPT.EM 273)
(RPAQQ CURSORBITMAP.EM 281)
(RPAQQ KBDAD0.EM 65052)
(RPAQQ KBDAD1.EM 65053)
(RPAQQ KBDAD2.EM 65054)
(RPAQQ KBDAD3.EM 65055)
(RPAQQ UTILIN.EM 65048)
(RPAQQ CURSORX.EM 278)
(RPAQQ CURSORY.EM 279)
(RPAQQ MOUSEX.EM 276)
(RPAQQ MOUSEY.EM 277)
(RPAQQ |\\LispKeyMask| 8192)
(RPAQQ |\\BcplKeyMask| 4352)
(RPAQQ \\MAIKO 3)
(RPAQQ \\DOLPHIN 4)
(RPAQQ \\DORADO 5)
(RPAQQ \\DANDELION 6)
(RPAQQ \\DAYBREAK 8)
(RPAQQ \\VP.DISPLAY 4608)
(RPAQQ \\NP.DISPLAY 202)
(RPAQQ \\NP.WIDEDOVEDISPLAY 243)
(RPAQQ \\WIDEDOVEDISPLAYWIDTH 1152)
(RPAQQ \\RP.AFTERDISPLAY 206)
(RPAQQ \\RP.AFTERDOVEDISPLAY 243)
(RPAQQ \\RP.DISPLAY 0)
(RPAQQ \\RP.TEMPDISPLAY 2561)
(RPAQQ \\RP.MISCLOCKED 2804)
(RPAQQ \\RP.STACK 768)
(RPAQQ \\VP.STACK 256)
(RPAQQ \\RP.MAP 256)
(RPAQQ \\NP.MAP 256)
(RPAQQ \\RP.IOPAGE 512)
(RPAQQ \\RP.DOVEIOCBPAGE 543)
(RPAQQ \\RP.DOVEIORGN 544)
(RPAQQ \\VP.DOVEIORGN 64)
(RPAQQ \\DOVEIORGNSIZE 64)
(RPAQQ \\VP.IOPAGE 255)
(RPAQQ \\VP.IFPAGE 5120)
(RPAQQ \\VP.FPTOVP 512)
(RPAQQ \\NP.FPTOVP 4096)
(RPAQQ \\RP.FPTOVP 1024)
(RPAQQ \\RP.STARTBUFFERS 640)
(RPAQQ \\VP.TYPETABLE 6144)
(RPAQQ \\NP.TYPETABLE 1024)
(RPAQQ \\RP.TYPETABLE 5120)
(RPAQQ \\VP.GCTABLE 5632)
(RPAQQ \\NP.GCTABLE 256)
(RPAQQ \\RP.GCTABLE 6144)
(RPAQQ \\VP.GCOVERFLOW 5888)
(RPAQQ \\NP.GCOVERFLOW 1)
(RPAQQ \\RP.GCOVERFLOW 6400)
(RPAQQ \\FP.IFPAGE 2)
(RPAQQ \\VP.IOCBS 1)
(RPAQQ \\VP.PRIMARYMAP 5122)
(RPAQQ \\VP.SECONDARYMAP 1280)
(RPAQQ \\VP.LPT 5232)
(RPAQQ \\VP.INITSCRATCH 8)
(RPAQQ \\VP.RPT 128)
(RPAQQ \\VP.BUFFERS 218)
(RPAQQ \\DL.PROCESSORBUSY 32768)
(RPAQQ \\DL.SETTOD 32769)
(RPAQQ \\DL.READTOD 32770)
(RPAQQ \\DL.READPID 32771)
(RPAQQ \\DL.BOOTBUTTON 32772)
(CONSTANTS (CDRCODING 1) (\\SMALLP 1) (\\FIXP 2) (\\FLOATP 3) (\\LITATOM 4) (\\LISTP 5) (\\ARRAYP 6) (
\\STRINGP 7) (\\STACKP 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10) (\\STREAM 11) (\\TT.TYPEMASK 2047) (
\\TT.NOREF 32768) (\\TT.SYMBOLP 16384) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 2048) (
|\\PMblockSize| 32) (|\\STATSsize| 8) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535) (
|\\FirstVmemBlock| 2) (\\MAXVMPAGE 131069) (\\MAXVMSEGMENT 255) (|\\IFPValidKey| 5603) (
|\\FirstMDSPage| 16382) (|\\MaxMDSPage| 524285) (|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512
) (|\\PagesPerMDSUnit| 2) (|\\FirstArraySegment| 46) (|\\FirstArrayPage| 11776) (
|\\DefaultSecondArrayPage| 16384) (|\\StackMask| 57344) (|\\FxtnBlock| 49152) (|\\GuardBlock| 57344) (
|\\BFBlock| 32768) (|\\FreeStackBlock| 40960) (|\\NotStackBlock| 0) (|\\MinExtraStackWords| 32) (
ERASECHARCODE 0) (\\HT1CNT 1024) (\\HTSTKBIT 512) (\\HTCNTMASK 64512) (\\HTMAINSIZE 65536) (
\\HTCOLLSIZE 1048576) (\\HTENDFREE 1) (\\HTFREEPTR 0) (|\\AtomHI| 0) (\\CHARHI 7) (|\\AtomHTpages| 256
) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) (|\\SmallPosHi| 14) (|\\SmallNegHi| 15) (
|\\NumSmallPages| 512) (\\PNAME.HI 8) (\\ATOM.HI 44) (\\DEF.HI 10) (\\VAL.HI 12) (\\PLIST.HI 2) (
|\\NumPageMapPages| 256) (|\\MDSTTsize| 1024) (|\\UFNTableSize| 2) (|\\DTDSize| 18) (|\\EndTypeNumber|
 2047) (|\\NumLPTPages| 16) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 1) (
|\\HTMAINnpages| 256) (|\\D1BCPLspace| 0) (|\\D0BCPLspace| 0) (|\\CurrentFXP| 0) (|\\ResetFXP| 1) (
|\\SubovFXP| 2) (|\\KbdFXP| 3) (|\\HardReturnFXP| 4) (\\GCFXP 5) (\\FAULTFXP 6) (|\\MiscFXP| 14) (
|\\TeleRaidFXP| 24) (DCB.EM 272) (DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (
KBDAD1.EM 65053) (KBDAD2.EM 65054) (KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 
279) (MOUSEX.EM 276) (MOUSEY.EM 277) (|\\LispKeyMask| 8192) (|\\BcplKeyMask| 4352) (\\MAIKO 3) (
\\DOLPHIN 4) (\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (\\VP.DISPLAY 4608) (\\NP.DISPLAY 202) (
\\NP.WIDEDOVEDISPLAY 243) (\\WIDEDOVEDISPLAYWIDTH 1152) (\\RP.AFTERDISPLAY 206) (\\RP.AFTERDOVEDISPLAY
 243) (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (\\RP.STACK 768) (\\VP.STACK 256
) (\\RP.MAP 256) (\\NP.MAP 256) (\\RP.IOPAGE 512) (\\RP.DOVEIOCBPAGE 543) (\\RP.DOVEIORGN 544) (
\\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 5120) (\\VP.FPTOVP 512) (
\\NP.FPTOVP 4096) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 6144) (\\NP.TYPETABLE 
1024) (\\RP.TYPETABLE 5120) (\\VP.GCTABLE 5632) (\\NP.GCTABLE 256) (\\RP.GCTABLE 6144) (
\\VP.GCOVERFLOW 5888) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 6400) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) (
\\VP.PRIMARYMAP 5122) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 5232) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) (
\\VP.BUFFERS 218) (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) (\\DL.READTOD 32770) (\\DL.READPID 
32771) (\\DL.BOOTBUTTON 32772))
(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 8 "Loop in \\SELECTREALPAGE") (
\\MP.NEWPAGE 9 "Attempt to allocate already existing page") (\\MP.NEWMAPPAGE 10 
"\\DONEWPAGE failed to allocate new map page") (\\MP.BADLOCKED 11 
"Locked page occupies a file page needed to lock another") (\\MP.CLOCK0 12 
"Arg to CLOCK0 not an integer box") (\\MP.RESIDENT 13 "Fault on resident page") (\\MP.STACKFAULT 14 
"Fault on stack") (\\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") (
\\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\\MP.UNINTERRUPTABLE 18 
"Error in uninterruptable system code") (\\MP.STACKFULL 19) (\\MP.MDSFULL 20) (\\MP.UNKNOWN.UFN 21) (
\\MP.ATOMSFULL 22) (\\MP.PNAMESFULL 23) (\\MP.USECOUNTOVERFLOW 24) (\\MP.MDSFULLWARNING 25) (
\\MP.BADMDSFREELIST 26) (\\MP.BADARRAYBLOCK 27) (\\MP.BADDELETEBLOCK 28) (\\MP.BADARRAYRECLAIM 29) (
\\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") (
\\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\\MP.DELREF0 32) (\\MP.PROCERROR 33)
 (\\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\\MP.32MBINUSE 35) (\\MP.TOPUNWOUND 36
 "Unexpected (RETTO T)") (\\MP.STACKRELEASED 37) (\\MP.FLUSHLOCKED 38) (\\MP.MAPNOTLOCKED 39) (
\\MP.UNLOCKINGMAP 40) (\\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\\MP.BADRUNTABLE 42 
"Malformed run table for vmem file")))
(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 8 "Loop in \\SELECTREALPAGE")
(RPAQ \\MP.NEWPAGE 9 "Attempt to allocate already existing page")
(RPAQ \\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page")
(RPAQ \\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another")
(RPAQ \\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box")
(RPAQ \\MP.RESIDENT 13 "Fault on resident page")
(RPAQ \\MP.STACKFAULT 14 "Fault on stack")
(RPAQ \\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)")
(RPAQ \\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T")
(RPAQ \\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code")
(RPAQQ \\MP.STACKFULL 19)
(RPAQQ \\MP.MDSFULL 20)
(RPAQQ \\MP.UNKNOWN.UFN 21)
(RPAQQ \\MP.ATOMSFULL 22)
(RPAQQ \\MP.PNAMESFULL 23)
(RPAQQ \\MP.USECOUNTOVERFLOW 24)
(RPAQQ \\MP.MDSFULLWARNING 25)
(RPAQQ \\MP.BADMDSFREELIST 26)
(RPAQQ \\MP.BADARRAYBLOCK 27)
(RPAQQ \\MP.BADDELETEBLOCK 28)
(RPAQQ \\MP.BADARRAYRECLAIM 29)
(RPAQ \\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.")
(RPAQ \\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table")
(RPAQQ \\MP.DELREF0 32)
(RPAQQ \\MP.PROCERROR 33)
(RPAQ \\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use")
(RPAQQ \\MP.32MBINUSE 35)
(RPAQ \\MP.TOPUNWOUND 36 "Unexpected (RETTO T)")
(RPAQQ \\MP.STACKRELEASED 37)
(RPAQQ \\MP.FLUSHLOCKED 38)
(RPAQQ \\MP.MAPNOTLOCKED 39)
(RPAQQ \\MP.UNLOCKINGMAP 40)
(RPAQ \\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper")
(RPAQ \\MP.BADRUNTABLE 42 "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 
8 "Loop in \\SELECTREALPAGE") (\\MP.NEWPAGE 9 "Attempt to allocate already existing page") (
\\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page") (\\MP.BADLOCKED 11 
"Locked page occupies a file page needed to lock another") (\\MP.CLOCK0 12 
"Arg to CLOCK0 not an integer box") (\\MP.RESIDENT 13 "Fault on resident page") (\\MP.STACKFAULT 14 
"Fault on stack") (\\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") (
\\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\\MP.UNINTERRUPTABLE 18 
"Error in uninterruptable system code") (\\MP.STACKFULL 19) (\\MP.MDSFULL 20) (\\MP.UNKNOWN.UFN 21) (
\\MP.ATOMSFULL 22) (\\MP.PNAMESFULL 23) (\\MP.USECOUNTOVERFLOW 24) (\\MP.MDSFULLWARNING 25) (
\\MP.BADMDSFREELIST 26) (\\MP.BADARRAYBLOCK 27) (\\MP.BADDELETEBLOCK 28) (\\MP.BADARRAYRECLAIM 29) (
\\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") (
\\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\\MP.DELREF0 32) (\\MP.PROCERROR 33)
 (\\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\\MP.32MBINUSE 35) (\\MP.TOPUNWOUND 36
 "Unexpected (RETTO T)") (\\MP.STACKRELEASED 37) (\\MP.FLUSHLOCKED 38) (\\MP.MAPNOTLOCKED 39) (
\\MP.UNLOCKINGMAP 40) (\\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\\MP.BADRUNTABLE 42 
"Malformed run table for vmem file"))
(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 31)))
(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 43)))
(BLOCKRECORD IOPAGE ((NIL 18 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 32 WORD) (DLIOPHARDWARECONFIG WORD) (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) (
DLRS232CPARAMETERCSBHI.11 WORD) (DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) (
DLETHERNET 12 WORD) (NIL 31 WORD) (DLDISPINTERRUPT WORD) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) (
DLCURSORX WORD) (DLCURSORY WORD) (DLCURSORBITMAP 16 WORD)) (ACCESSFNS IOPAGE ((DLCURSORBITMAPPTR (
\\ADDBASE DATUM 240)) (DLCURSORYPTR (\\ADDBASE DATUM 239)) (DLCURSORXPTR (\\ADDBASE DATUM 238)) (
DLDISPINTERRUPTPTR (\\ADDBASE DATUM 235)) (DLETHERNETPTR (\\ADDBASE DATUM 192)) (DLKBDAD5PTR (
\\ADDBASE DATUM 67)) (DLKBDAD4PTR (\\ADDBASE DATUM 66)) (DLKBDAD3PTR (\\ADDBASE DATUM 65)) (
DLKBDAD2PTR (\\ADDBASE DATUM 64)) (DLKBDAD1PTR (\\ADDBASE DATUM 63)) (DLKBDAD0PTR (\\ADDBASE DATUM 62)
) (DLUTILINPTR (\\ADDBASE DATUM 61)) (DLMOUSEYPTR (\\ADDBASE DATUM 60)) (DLMOUSEXPTR (\\ADDBASE DATUM 
59)) (DLTODLOPTR (\\ADDBASE DATUM 56)) (DLMAINTPANELPTR (\\ADDBASE DATUM 18)))) (CREATE (\\ALLOCBLOCK 
128)))
(PUTPROPS EMADDRESS MACRO (ARGS ((LAMBDA (ADDR) (COND ((EQ |\\D1BCPLspace| |\\D0BCPLspace|) (LIST (
BIG-VMEM-CODE (LIST (QUOTE OPCODES) (QUOTE GCONST) 0 0 (LRSH ADDR 8) (LOGAND ADDR 255)) (LIST (QUOTE 
OPCODES) (QUOTE GCONST) 0 (LRSH ADDR 8) (LOGAND ADDR 255))))) (T (BQUOTE (\\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 (QUOTE \\VAG2) (QUOTE 
(|fetch| (IFPAGE |EmulatorSpace|) |of| |\\InterfacePage|)) (CAR X))) ((ZEROP (CAR X)) NIL) (T (LIST (
QUOTE \\VAG2) |\\D0BCPLspace| (CAR X))))))
(PUTPROPS EMADDRESSP MACRO (X (LIST (QUOTE EQ) (LIST (QUOTE \\HILOC) (CAR X)) (COND ((EQ 
|\\D1BCPLspace| |\\D0BCPLspace|) |\\D0BCPLspace|) (T (QUOTE (|fetch| (IFPAGE |EmulatorSpace|) |of| 
|\\InterfacePage|)))))))
(PUTPROP (QUOTE LLPARAMS) (QUOTE IMPORTDATE) (IDATE "31-Jan-1998 09:16:51"))

(DATATYPE COMPILED-CLOSURE (FNHEADER ENVIRONMENT))
(RPAQQ \\COMPILED-CLOSURE 13)
(CONSTANTS \\COMPILED-CLOSURE)
(PUTPROPS \\EXTENDED.EQP MACRO (OPENLAMBDA (X Y) (COND ((EQ (NTYPX X) (NTYPX Y)) (SELECTC (NTYPX X) (
\\STACKP (EQ (|fetch| (STACKP EDFXP) |of| X) (|fetch| (STACKP EDFXP) |of| Y))) (\\COMPILED-CLOSURE (
EQDEFP X Y)) NIL)))))
(PUTPROPS DPUTCODE MACRO ((FN CA SIZE) (SELECTQ (SYSTEMTYPE) (D (DEFC FN CA)) (/PUTPROP FN (QUOTE 
DCODE) CA))))
(PUTPROPS MCODEP MACRO ((X) (OR (ARRAYP X) (AND (LITATOM X) (ARRAYP (SELECTQ (SYSTEMTYPE) (D (GETD X))
 (GETPROP X (QUOTE DCODE))))))))
(PUTPROPS CODELT MACRO ((CA N) (\\BYTELT CA N)))
(PUTPROPS CODELT2 MACRO (OPENLAMBDA (DEF LC) (LOGOR (LLSH (CODELT DEF LC) BITSPERBYTE) (CODELT DEF (
ADD1 LC)))))
(PUTPROPS CODESETA2 MACRO (OPENLAMBDA (DEF LC VALUE) (CODESETA DEF LC (LRSH VALUE BITSPERBYTE)) (
CODESETA DEF (ADD1 LC) (IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE))))))
(PUTPROPS CODESETA MACRO ((CA N NV) (\\BYTESETA CA N NV)))
(PUTPROPS BYTESPERNAMEENTRY MACRO (NIL (UNFOLD (CONSTANT (WORDSPERNAMEENTRY)) BYTESPERWORD)))
(PUTPROPS BYTESPERNTOFFSETENTRY MACRO (NIL (UNFOLD (WORDSPERNAMEENTRY) BYTESPERWORD)))
(PUTPROPS GETNAMEENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (* |;;| 
"Must ALWAYS be called with DEF really being either a FNHEADER or a nametable pseudo-fnheader.  Never use addbase to offset from it.  This is because CODEBASEELT checks the BYTESWAPPED flag in the fnheader...."
) (FOR I FROM 0 TO (CONSTANT (SUB1 (BYTESPERNAMEENTRY))) DO (SETQ NUMBER (LOGOR (LLSH NUMBER 
BITSPERBYTE) (CODEBASELT DEF (IPLUS LC I))))) NUMBER)))
(PUTPROPS GETNTFLAGS MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF LC)))
(PUTPROPS GETNTOFFSET MACRO (OPENLAMBDA (DEF LC) (NTSLOT-OFFSET (GETNTOFFSETENTRY DEF LC))))
(PUTPROPS GETNTOFFSETENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (|for| I |from| 0 |to| (
CONSTANT (SUB1 (BYTESPERNTOFFSETENTRY))) |do| (SETQ NUMBER (LOGOR (LLSH NUMBER BITSPERBYTE) (
CODEBASELT DEF (IPLUS LC I))))) NUMBER)))
(PUTPROPS GETNTTAG MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF (ADD1 LC))))
(PUTPROPS SETNAMEENTRY MACRO (OPENLAMBDA (DEF LC VALUE) (FOR I FROM (CONSTANT (SUB1 (BYTESPERNAMEENTRY
))) TO 0 BY -1 DO (CODEBASESETA DEF (IPLUS LC I) (LOGAND VALUE (CONSTANT (SUB1 (LLSH 1 BITSPERBYTE))))
) (SETQ VALUE (LRSH VALUE BITSPERBYTE)))))
(PUTPROPS WORDSPERNTOFFSETENTRY MACRO (NIL (WORDSPERNAMEENTRY)))
(PUTPROPS NTSLOT-OFFSET MACRO ((X) (LOGAND 255 X)))
(DEFMACRO NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM) (* |;;| 
"Use one form or another, depending on whether we're compiling for new 3-byte atoms or old 2-byte atom numbers."
) (COND ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*) (* \; "NEW ATOMS") (BQUOTE (\\\, 
NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, OLD-SYMBOL-FORM)))))
(DEFOPTIMIZER BIG-VMEM-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* |;;| 
"Allow for differences between 4-byte pointers and 3-byte pointers..") (COND ((FMEMB :4-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, 
OLD-SYMBOL-FORM)))))
(DEFOPTIMIZER SETSTKNAMEENTRY (CODEARRAY OFFSET VAL &ENVIRONMENT ENV) (* |;;| 
"Set the name entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE
 ENV)) (BQUOTE (LET ((BASE (|fetch| (ARRAYP BASE) |of| (\\\, CODEARRAY))) (VALUE (\\\, VAL))) (COND ((
FIXP VALUE) (* \; "A 20-byte atom #.  Make it an atom.") (\\PUTBASEPTR BASE (\\\, OFFSET) (\\VAG2 
|\\AtomHI| VALUE))) (T (* \; "A 3-byte atom.  Just use it.") (\\PUTBASEPTR BASE (\\\, OFFSET) VALUE)))
))) (T (BQUOTE (LET ((BASE (|fetch| (ARRAYP BASE) |of| (\\\, CODEARRAY)))) (\\PUTBASE BASE (\\\, 
OFFSET) (\\\, VAL)))))))
(DEFOPTIMIZER SETSTKNTOFFSETENTRY (BASE OFFSET VAL &ENVIRONMENT ENV) (* |;;| 
"Set the offset entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE
 ENV)) (BQUOTE (\\PUTBASEFIXP (\\\, BASE) (\\\, OFFSET) (\\\, VAL)))) (T (BQUOTE (\\PUTBASE (\\\, BASE
) (\\\, OFFSET) (\\\, VAL))))))
(DEFOPTIMIZER GETSTKNAMEENTRY (BASE OFFSET &ENVIRONMENT ENV) (* |;;| 
"Get a name entry out of a name table.  BASE is the start of the name table; OFFSET is in words, not bytes or name entries."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\GETBASEPTR (\\\, BASE) (
\\\, OFFSET)))) (T (BQUOTE (\\GETBASE (\\\, BASE) (\\\, OFFSET))))))
(DEFOPTIMIZER GETSTKNTOFFSETENTRY (BASE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\GETBASEFIXP (\\\, BASE) (\\\, OFFSET)))) (T (BQUOTE
 (\\GETBASE (\\\, BASE) (\\\, OFFSET))))))
(DEFOPTIMIZER WORDSPERNAMEENTRY (&ENVIRONMENT ENV) (* |;;| 
"Number of words in a name-table \"Name\" entry--the space for the symbol.  1 for old symbol systems, 2 for 3-byte-atom systesm."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN 2))) ((AND 
CROSSCOMPILING (FMEMB :3-BYTE-INIT (COMPILER::ENV-TARGET-ARCHITECTURE ENV))) (BQUOTE (PROGN 2))) (T (
BQUOTE (PROGN 1)))))
(DEFOPTIMIZER SETSTKNTOFFSET (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* |;;| 
"Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\\FIXCODENUM (\\\, 
BASE) (IDIFFERENCE (\\\, OFFSET) BYTESPERWORD) (\\\, TYPE)) (\\FIXCODENUM (\\\, BASE) (\\\, OFFSET) (
\\\, VAL))))) (T (BQUOTE (\\FIXCODENUM (\\\, BASE) (\\\, OFFSET) (IPLUS (\\\, TYPE) (\\\, VAL)))))))
(DEFOPTIMIZER SETSTKNAME-RAW (BASE OFFSET VAL &ENVIRONMENT ENV) (* |;;| 
"Set the name entry for a name-table entry. This version works with raw storage, as opposed to SETSTKNAMEENTRY, which works on an ARRAYP."
) (* |;;| "If this optimizer changes, change SETSTKNAMEENTRY as well.") (COND ((FMEMB :3-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LET ((VALUE (\\\, VAL))) (COND ((FIXP VALUE) (* \; 
"A 20-byte atom #.  Make it an atom.") (\\PUTBASEPTR (\\\, BASE) (\\\, OFFSET) (\\VAG2 |\\AtomHI| 
VALUE))) (T (* \; "A 3-byte atom.  Just use it.") (\\PUTBASEPTR (\\\, BASE) (\\\, OFFSET) VALUE)))))) 
(T (BQUOTE (\\PUTBASE (\\\, BASE) (\\\, OFFSET) (\\\, VAL))))))
(DEFOPTIMIZER SETSTKNTOFFSET-RAW (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* |;;| 
"Set the offset entry for a name-table entry.  This version works on raw storage, vs SETSTKNAMEOFFSETENTRY, which is supposed to work on codearrays.  Any changes here should be made there, as well.  TYPE must already be shifted left by 14 bits."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\\PUTBASE (\\\, BASE)
 (\\\, OFFSET) (\\\, TYPE)) (\\PUTBASE (\\\, BASE) (IPLUS (\\\, OFFSET) 1) (\\\, VAL))))) (T (BQUOTE (
\\PUTBASE (\\\, BASE) (\\\, OFFSET) (IPLUS (\\\, TYPE) (\\\, VAL)))))))
(DEFOPTIMIZER NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* |;;| 
"Allow for differences between 3-byte atoms and 2-byte atoms.") (COND ((FMEMB :3-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, 
OLD-SYMBOL-FORM)))))
(DEFOPTIMIZER MAKE-NTENTRY (TYPE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (IPLUS (CONSTANT (LLSH (\\\, TYPE) 16)) (\\\, OFFSET))
)) (T (BQUOTE (IPLUS (CONSTANT (\\\, TYPE)) (\\\, OFFSET))))))
(DEFOPTIMIZER NULL-NTENTRY (VALUE &ENVIRONMENT ENV) (* |;;| 
"Predicate:  Is  VALUE a null entry in a name table?  I.e., does it result from fetching the entry at the end that`s all zeros?  For 2-byte atoms, that's the same as being zero.  For 3-byte atoms, it's the same as being NIL."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (NULL (\\\, VALUE)))) (T (
BQUOTE (EQ (\\\, VALUE) 0)))))
(DEFOPTIMIZER NTSLOT-VARTYPE (X &ENVIRONMENT ENV) (* |;;| 
"Given the contents of a name-table Offset entry, return the variable-type bits at the top of the entry.  THE RESULT IS RETURNED SHEFTED LEFT 14 BITS, THE USUAL REPRESENTATION."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LOGAND 49153 (LRSH (\\\, X) 
16)))) (T (BQUOTE (LOGAND (\\\, X) 49152)))))
(ACCESSFNS CODEARRAY ((STKMIN (CODELT2 DATUM 0) (CODESETA2 DATUM 0 NEWVALUE)) (NA (SIGNED (CODELT2 
DATUM 2) BITSPERWORD) (CODESETA2 DATUM 2 (UNSIGNED NEWVALUE BITSPERWORD))) (PV (SIGNED (CODELT2 DATUM 
4) BITSPERWORD) (CODESETA2 DATUM 4 (UNSIGNED NEWVALUE BITSPERWORD))) (STARTPC (CODELT2 DATUM 6) (
CODESETA2 DATUM 6 NEWVALUE)) (ARGTYPE (LOGAND (LRSH (CODELT DATUM 8) 4) 3) (CODESETA DATUM 8 (LOGOR (
LOGAND (CODELT DATUM 8) 207) (LLSH (LOGAND NEWVALUE 3) 4)))) (FRAMENAME (\\VAG2 (LOGAND (CODELT2 DATUM
 8) 4095) (CODELT2 DATUM 10)) (\\FIXCODEPTR DATUM 11 (EVQ NEWVALUE))) (NTSIZE (CODELT2 DATUM 12) (
CODESETA2 DATUM 12 NEWVALUE)) (NLOCALS (CODELT DATUM 14) (CODESETA DATUM 14 NEWVALUE)) (FVAROFFSET (
CODELT DATUM 15) (CODESETA DATUM 15 NEWVALUE))) (ACCESSFNS CODEARRAY ((LSTARP (ILESSP (|fetch| (
CODEARRAY NA) |of| DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (ALIGNED (IPLUS (|fetch| (CODEARRAY NTSIZE) 
|of| DATUM) (|fetch| (CODEARRAY OVERHEADWORDS) |of| T))) (FIXED NIL (|replace| (CODEARRAY STKMIN) |of|
 DATUM |with| (\\STKMIN DATUM))) (FRAMENAME# (PROGN 8)))))
(RECORD OPCODE (OP# OPCODENAME OPNARGS OPPRINT LEVADJ UFNFN UNIMPL))
(GLOBALVARS \\OPCODES)
(RPAQQ PVARCODE 32768)
(RPAQQ FVARCODE 49152)
(RPAQQ IVARCODE 0)
(RPAQQ VARCODEMASK 49152)
(CONSTANTS PVARCODE FVARCODE IVARCODE VARCODEMASK)
(RPAQQ \\NT.IVARCODE 0)
(RPAQQ \\NT.PVARCODE 2)
(RPAQQ \\NT.FVARCODE 3)
(CONSTANTS \\NT.IVARCODE \\NT.PVARCODE \\NT.FVARCODE)
(PUTPROP (QUOTE LLCODE) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 10:45:33"))

(RPAQQ \\ERRORMESSAGELIST ("SYSTEM ERROR" " " "STACK OVERFLOW" "ILLEGAL RETURN" "ARG NOT LIST" 
"HARD DISK ERROR" "ATTEMPT TO SET NIL OR T" "ATTEMPT TO RPLAC NIL" "UNDEFINED OR ILLEGAL GO" 
"FILE WON'T OPEN" "NON-NUMERIC ARG" "ATOM TOO LONG" "ATOM HASH TABLE FULL" "FILE NOT OPEN" 
"ARG NOT LITATOM" "! too many files open" "END OF FILE" "ERROR" "BREAK" "ILLEGAL STACK ARG" 
"FAULT IN EVAL" "ARRAYS FULL" "FILE SYSTEM RESOURCES EXCEEDED" "FILE NOT FOUND" "BAD SYSOUT FILE" 
"UNUSUAL CDR ARG LIST" "HASH TABLE FULL" "ILLEGAL ARG" "ARG NOT ARRAY" "ILLEGAL OR IMPOSSIBLE BLOCK" 
"STACK PTR HAS BEEN RELEASED" "STORAGE FULL" "ATTEMPT TO USE ITEM OF INCORRECT TYPE" 
"ILLEGAL DATA TYPE NUMBER" "DATA TYPES FULL" "ATTEMPT TO BIND NIL OR T" 
"! too many user interrupt characters" "! read-macro context error" "ILLEGAL READTABLE" 
"ILLEGAL TERMINAL TABLE" "! swapblock too big for buffer" "PROTECTION VIOLATION" "BAD FILE NAME" 
"USER BREAK" "UNBOUND ATOM" "UNDEFINED CAR OF FORM" "UNDEFINED FUNCTION" "CONTROL-E" 
"FLOATING UNDERFLOW" "FLOATING OVERFLOW" "OVERFLOW" "ARG NOT HARRAY" "TOO MANY ARGUMENTS"))
(DEFOPTIMIZER LISPERROR (MESSAGE ARG) (BQUOTE (\\LISPERROR (\\\, ARG) (\\\, (CL:IF (CL:STRINGP MESSAGE
) (FOR X IN \\ERRORMESSAGELIST AS I FROM 0 WHEN (CL:EQUAL X MESSAGE) DO (RETURN I) FINALLY (RETURN (
HELP "Unknown error message" (LIST MESSAGE ARG)))) MESSAGE)))))
(PUTPROP (QUOTE AERROR) (QUOTE IMPORTDATE) (IDATE "16-May-1990 11:58:35"))

(RECORD BASEBYTESTREAM STREAM (SUBRECORD STREAM) (ACCESSFNS ((BIASOFFST (|fetch| (STREAM FW6) |of| 
DATUM) (|replace| (STREAM FW6) |of| DATUM |with| NEWVALUE)) (BBSNCHARS (|fetch| (STREAM FW7) |of| 
DATUM) (|replace| (STREAM FW7) |of| DATUM |with| NEWVALUE)) (WRITEXTENSIONFN (|fetch| (STREAM F1) |of|
 DATUM) (|replace| (STREAM F1) |of| DATUM |with| NEWVALUE)))))
(PUTPROPS \\INSTREAMARG MACRO ((STRM NOERRORFLG) (\\GETSTREAM STRM (QUOTE INPUT) NOERRORFLG)))
(PUTPROPS \\OUTSTREAMARG MACRO ((STRM NOERRORFLG) (\\GETSTREAM STRM (QUOTE OUTPUT) NOERRORFLG)))
(PUTPROPS \\STREAMARG MACRO (OPENLAMBDA (STRM NOERRORFLG) (COND (NOERRORFLG (\\GETSTREAM STRM NIL T)) 
(T (\\DTEST STRM (QUOTE STREAM))))))
(PUTPROP (QUOTE AOFD) (QUOTE IMPORTDATE) (IDATE "13-Sep-1990 16:39:58"))

(PUTPROPS .SPACECHECK. MACRO ((STRM N) (AND \\THISFILELINELENGTH (IGREATERP (IPLUS N (|fetch| 
CHARPOSITION |of| STRM)) \\THISFILELINELENGTH) (FRESHLINE STRM))))
(PUTPROPS \\CHECKRADIX MACRO (LAMBDA (R) (COND ((OR (NOT (SMALLP R)) (ILESSP R 1) (IGREATERP R 36)) (
\\INVALID.RADIX R)) (T R))))
(PUTPROPS \\XCCSFILEOUTCHARFN MACRO ((OUTSTREAM CHARCODE) (* |;;;| 
"Encoder for XCCS format.  Default decoder.") (COND ((EQ CHARCODE (CHARCODE EOL)) (COND ((NOT (
\\RUNCODED OUTSTREAM)) (* \; "Charset is a constant 0") (\\BOUT OUTSTREAM (\\CHARSET (CHARCODE EOL))))
 ((EQ (\\CHARSET (CHARCODE EOL)) (|ffetch| (STREAM CHARSET) |of| OUTSTREAM))) (T (\\BOUT OUTSTREAM 
NSCHARSETSHIFT) (\\BOUT OUTSTREAM (|freplace| (STREAM CHARSET) |of| OUTSTREAM |with| (\\CHARSET (
CHARCODE EOL)))))) (\\BOUT OUTSTREAM (SELECTC (|ffetch| EOLCONVENTION |of| OUTSTREAM) (CR.EOLC (
CHARCODE CR)) (LF.EOLC (CHARCODE LF)) (CRLF.EOLC (\\BOUT OUTSTREAM (CHARCODE CR)) (* |;;| 
"Don't put out high-order byte preceding LF.  The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes"
) (CHARCODE LF)) (SHOULDNT))) (|freplace| CHARPOSITION |of| OUTSTREAM |with| 0)) (T (COND ((NOT (
\\RUNCODED OUTSTREAM)) (\\BOUT OUTSTREAM (\\CHARSET CHARCODE)) (\\BOUT OUTSTREAM (\\CHAR8CODE CHARCODE
))) ((EQ (\\CHARSET CHARCODE) (|ffetch| (STREAM CHARSET) |of| OUTSTREAM)) (\\BOUT OUTSTREAM (
\\CHAR8CODE CHARCODE))) (T (\\BOUT OUTSTREAM NSCHARSETSHIFT) (\\BOUT OUTSTREAM (|freplace| (STREAM 
CHARSET) |of| OUTSTREAM |with| (\\CHARSET CHARCODE))) (\\BOUT OUTSTREAM (\\CHAR8CODE CHARCODE)))) (
|freplace| CHARPOSITION |of| OUTSTREAM |with| (PROGN (* \; "Ugh.  Don't overflow") (IPLUS16 (|ffetch| 
CHARPOSITION |of| OUTSTREAM) 1)))))))
(PUTPROP (QUOTE APRINT) (QUOTE IMPORTDATE) (IDATE "17-Jan-2020 05:51:20"))

(GLOBALVARS \\BCPLDISPLAY)
(ACCESSFNS LINEBUFFER ((LPARCOUNT (|fetch| FW6 |of| DATUM) (|replace| FW6 |of| DATUM |with| NEWVALUE))
 (LBRKCOUNT (|fetch| FW7 |of| DATUM) (|replace| FW7 |of| DATUM |with| NEWVALUE)) (LINEBUFSTATE (
|fetch| F5 |of| DATUM) (|replace| F5 |of| DATUM |with| NEWVALUE)) (* \; "F4 is free.  EJS, 7/8/85") (
KEYBOARDSTREAM (|fetch| F2 |of| DATUM) (|replace| F2 |of| DATUM |with| NEWVALUE)) (PEEKEDCHAR (|fetch|
 F3 |of| DATUM) (|replace| F3 |of| DATUM |with| NEWVALUE)) (* \; "Character read by PEEKC") (LBFLAGS (
|fetch| FW9 |of| DATUM) (|replace| FW9 |of| DATUM |with| NEWVALUE)) (* |;;| 
"True if peeked char was echoed when peeked.  Could use this to determine whether to echo later or not, but that would be incompatible with Interlisp-10, so this field not used"
)) (ACCESSFNS LINEBUFFER ((LBFLAGBASE (LOCF (|fetch| LBFLAGS |of| DATUM)))) (BLOCKRECORD LBFLAGBASE ((
PEEKEDECHOFLG FLAG) (INSTRINGP FLAG)))))
(RPAQQ LINEBUFFERSTATES (FILLING.LBS READING.LBS RETYPING.LBS))
(RPAQQ FILLING.LBS 0)
(RPAQQ READING.LBS 1)
(RPAQQ RETYPING.LBS 2)
(CONSTANTS FILLING.LBS READING.LBS RETYPING.LBS)
(PUTPROPS \\INTERMP MACRO ((OFD) (EQ OFD \\LINEBUF.OFD)))
(PUTPROPS \\OUTTERMP MACRO ((OFD) (EQ OFD \\TERM.OFD)))
(GLOBALVARS \\DEFAULTLINEBUF)
(PUTPROP (QUOTE ATERM) (QUOTE IMPORTDATE) (IDATE "16-May-1990 12:08:04"))

(DATATYPE HARRAYP ((NULLSLOTS WORD) (* \; "Number of NIL-NIL slots, which break chains") (LASTINDEX 
WORD) (* \; 
"Slot offset of last slot.  Used in probe computations computations.  Microcode support for \\ADDBASE4 would help"
) (HARRAYPBASE POINTER) (RECLAIMABLE FLAG) (* \; "True if keys can go away when no other refs") (
OVERFLOWACTION POINTER) (NUMSLOTS WORD) (* \; 
"The maximum number of logical slots--returned by HARRAYSIZE") (NUMKEYS WORD) (* \; 
"The number of distinct keys in the array") (HASHBITSFN POINTER) (EQUIVFN POINTER) (HASHUSERDATA 
POINTER)))
(PUTPROPS \\EQHASHINGBITS MACRO (OPENLAMBDA (X) (* \; 
"Spread out objects whose low bits are in small arithmetic progression, esp atoms") (LOGXOR (\\HILOC X
) (LOGXOR (LLSH (LOGAND (\\LOLOC X) 8191) 3) (LRSH (\\LOLOC X) 9)))))
(PUTPROPS \\ADDBASE2 MACRO (OPENLAMBDA (BASE N) (\\ADDBASE (\\ADDBASE BASE N) N)))
(PUTPROPS \\ADDBASE4 MACRO (OPENLAMBDA (BASE N) (\\ADDBASE2 (\\ADDBASE2 BASE N) N)))
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (|fetch| DTDSIZE |of| (\\GETDTD NTYPX)) 
WORDSPERCELL)))
(PUTPROPS \\BYTELT DMACRO (OPENLAMBDA (A J) (\\GETBASEBYTE (|fetch| (ARRAYP BASE) |of| A) (IPLUS (
|fetch| (ARRAYP OFFST) |of| A) J))))
(PUTPROPS \\BYTESETA DMACRO (OPENLAMBDA (A J V) (\\PUTBASEBYTE (|fetch| (ARRAYP BASE) |of| A) (IPLUS (
|fetch| (ARRAYP OFFST) |of| A) J) V)))
(PUTPROPS \\WORDELT DMACRO (OPENLAMBDA (A J) (CHECK (AND (ARRAYP A) (EQ 0 (|fetch| (ARRAYP ORIG) |of| 
A)) (EQ \\ST.POS16 (|fetch| (ARRAYP TYP) |of| A)))) (CHECK (IGREATERP (|fetch| (ARRAYP LENGTH) |of| A)
 J)) (\\GETBASE (|fetch| (ARRAYP BASE) |of| A) (IPLUS (|fetch| (ARRAYP OFFST) |of| A) J))))
(RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (UNBOXEDBLOCK.GCT 0)))
(RPAQQ CODEBLOCK.GCT 2)
(RPAQQ PTRBLOCK.GCT 1)
(RPAQQ UNBOXEDBLOCK.GCT 0)
(CONSTANTS (CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (UNBOXEDBLOCK.GCT 0))
(RPAQQ ARRAYCONSTANTS (|\\ArrayBlockHeaderCells| |\\ArrayBlockHeaderWords| |\\ArrayBlockTrailerCells| 
|\\ArrayBlockTrailerWords| (|\\ArrayBlockOverheadCells| (IPLUS |\\ArrayBlockHeaderCells| 
|\\ArrayBlockTrailerCells|)) (|\\ArrayBlockOverheadWords| (IPLUS |\\ArrayBlockHeaderWords| 
|\\ArrayBlockTrailerWords|)) |\\ArrayBlockLinkingCells| (|\\MinArrayBlockSize| (IPLUS 
|\\ArrayBlockOverheadCells| |\\ArrayBlockLinkingCells|)) (|\\MaxArrayBlockSize| 65535) (
|\\MaxArrayNCells| (IDIFFERENCE |\\MaxArrayBlockSize| |\\ArrayBlockOverheadCells|)) |\\MaxArrayLen| (
\\ABPASSWORDSHIFT 3) (|\\ArrayBlockPassword| (LRSH 43690 \\ABPASSWORDSHIFT)) (|\\FreeArrayFlagWord| (
LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH UNBOXEDBLOCK.GCT 1))) (
|\\UsedArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) 1)) (
|\\CodeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT 1) 1)
)))
(RPAQQ |\\ArrayBlockHeaderCells| 1)
(RPAQQ |\\ArrayBlockHeaderWords| 2)
(RPAQQ |\\ArrayBlockTrailerCells| 1)
(RPAQQ |\\ArrayBlockTrailerWords| 2)
(RPAQ |\\ArrayBlockOverheadCells| (IPLUS |\\ArrayBlockHeaderCells| |\\ArrayBlockTrailerCells|))
(RPAQ |\\ArrayBlockOverheadWords| (IPLUS |\\ArrayBlockHeaderWords| |\\ArrayBlockTrailerWords|))
(RPAQQ |\\ArrayBlockLinkingCells| 2)
(RPAQ |\\MinArrayBlockSize| (IPLUS |\\ArrayBlockOverheadCells| |\\ArrayBlockLinkingCells|))
(RPAQQ |\\MaxArrayBlockSize| 65535)
(RPAQ |\\MaxArrayNCells| (IDIFFERENCE |\\MaxArrayBlockSize| |\\ArrayBlockOverheadCells|))
(RPAQQ |\\MaxArrayLen| 65535)
(RPAQQ \\ABPASSWORDSHIFT 3)
(RPAQ |\\ArrayBlockPassword| (LRSH 43690 \\ABPASSWORDSHIFT))
(RPAQ |\\FreeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH 
UNBOXEDBLOCK.GCT 1)))
(RPAQ |\\UsedArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) 1))
(RPAQ |\\CodeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT
 1) 1))
(CONSTANTS |\\ArrayBlockHeaderCells| |\\ArrayBlockHeaderWords| |\\ArrayBlockTrailerCells| 
|\\ArrayBlockTrailerWords| (|\\ArrayBlockOverheadCells| (IPLUS |\\ArrayBlockHeaderCells| 
|\\ArrayBlockTrailerCells|)) (|\\ArrayBlockOverheadWords| (IPLUS |\\ArrayBlockHeaderWords| 
|\\ArrayBlockTrailerWords|)) |\\ArrayBlockLinkingCells| (|\\MinArrayBlockSize| (IPLUS 
|\\ArrayBlockOverheadCells| |\\ArrayBlockLinkingCells|)) (|\\MaxArrayBlockSize| 65535) (
|\\MaxArrayNCells| (IDIFFERENCE |\\MaxArrayBlockSize| |\\ArrayBlockOverheadCells|)) |\\MaxArrayLen| (
\\ABPASSWORDSHIFT 3) (|\\ArrayBlockPassword| (LRSH 43690 \\ABPASSWORDSHIFT)) (|\\FreeArrayFlagWord| (
LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH UNBOXEDBLOCK.GCT 1))) (
|\\UsedArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) 1)) (
|\\CodeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT 1) 1)
))
(RPAQQ ARRAYTYPES ((\\ST.BYTE 0) (\\ST.POS16 1) (\\ST.INT32 2) (\\ST.CODE 4) (\\ST.PTR 6) (\\ST.FLOAT 
7) (\\ST.BIT 8) (\\ST.PTR2 11)))
(RPAQQ \\ST.BYTE 0)
(RPAQQ \\ST.POS16 1)
(RPAQQ \\ST.INT32 2)
(RPAQQ \\ST.CODE 4)
(RPAQQ \\ST.PTR 6)
(RPAQQ \\ST.FLOAT 7)
(RPAQQ \\ST.BIT 8)
(RPAQQ \\ST.PTR2 11)
(CONSTANTS (\\ST.BYTE 0) (\\ST.POS16 1) (\\ST.INT32 2) (\\ST.CODE 4) (\\ST.PTR 6) (\\ST.FLOAT 7) (
\\ST.BIT 8) (\\ST.PTR2 11))
(RPAQQ \\MAX.CELLSPERHUNK 64)
(CONSTANTS \\MAX.CELLSPERHUNK)
(RPAQQ \\IN.MAKEINIT NIL)
(CONSTANTS (\\IN.MAKEINIT))
(BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1) (NIL BITS 1) (READONLY FLAG) (NIL BITS 1) (BASE POINTER
) (TYP BITS 4) (NIL BITS 4) (LENGTH BITS 24) (OFFST FIXP)))
(DATATYPE ARRAYP ((* |;;| "Describes an INTERLISP ARRAYP, as opposed to a CL array.") (ORIG BITS 1) (*
 \; "Origin, 0 or 1") (NIL BITS 1) (READONLY FLAG) (* \; "probably no READONLY arrays now") (NIL BITS 
1) (BASE POINTER) (TYP BITS 4) (* \; "Type of the contents") (NIL BITS 4) (LENGTH BITS 24) (* \; 
"Array's length") (OFFST FIXP) (* \; "Offset from BASE where the data really starts.")) (* |;;| 
"note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}"
))
(BLOCKRECORD ARRAYBLOCK ((PASSWORD BITS 13) (GCTYPE BITS 2) (* \; "Unboxed, Pointers, or Code") (INUSE
 FLAG) (ARLEN WORD) (FWD FULLXPOINTER) (* \; "Only when on free list") (BKWD FULLXPOINTER)) (
BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD) (* \; "Used for header and trailer"))) (ACCESSFNS ARRAYBLOCK ((
DAT (\\ADDBASE DATUM |\\ArrayBlockHeaderWords|)) (TRAILER (\\ADDBASE2 DATUM (IDIFFERENCE (|fetch| (
ARRAYBLOCK ARLEN) |of| DATUM) |\\ArrayBlockTrailerCells|))))) (TYPE? (AND (EQ 0 (NTYPX DATUM)) (IGEQ (
\\HILOC DATUM) |\\FirstArraySegment|))))
(GLOBALVARS |\\NxtArrayPage| \\FREEBLOCKBUCKETS \\HUNKING?)
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (|fetch| DTDSIZE |of| (\\GETDTD NTYPX)) 
WORDSPERCELL)))
(PUTPROP (QUOTE LLARRAYELT) (QUOTE IMPORTDATE) (IDATE "15-Sep-1994 11:08:59"))

(DEFOPTIMIZER PUTBASEPTRX (&REST ARGS) (CONS (QUOTE (OPENLAMBDA (DATUM OFFSET NEWVALUE) (
UNINTERRUPTABLY (\\PUTBASE DATUM OFFSET (LOGOR (LOGAND 61440 (\\GETBASE DATUM OFFSET)) (LOGAND (
\\HILOC NEWVALUE) 4095))) (\\PUTBASE DATUM (ADD1 OFFSET) (\\LOLOC NEWVALUE)) NEWVALUE))) ARGS))
(RPAQQ \\SMALLP 1)
(RPAQQ \\FIXP 2)
(RPAQQ \\FLOATP 3)
(RPAQQ \\LITATOM 4)
(RPAQQ \\LISTP 5)
(RPAQQ \\ARRAYP 6)
(RPAQQ \\STACKP 8)
(RPAQQ \\VMEMPAGEP 10)
(RPAQQ \\STREAM 11)
(RPAQQ \\NEW-ATOM 21)
(CONSTANTS \\SMALLP \\FIXP \\FLOATP \\LITATOM \\LISTP \\ARRAYP \\STACKP \\VMEMPAGEP \\STREAM 
\\NEW-ATOM)
(RPAQQ \\BUILT-IN-SYSTEM-TYPES ((SMALLP) (FIXP 2) (FLOATP 2) (LITATOM) (LISTP 4 (0 2)) (ARRAYP 6 (0)) 
(STRINGP 6 (0)) (STACKP 2 NIL \\RECLAIMSTACKP) (CHARACTER) (VMEMPAGEP 256 NIL RELEASINGVMEMPAGE) (
STREAM) (BITMAP) (COMPILED-CLOSURE 4 (0 2)) (ONED-ARRAY 8 (0)) (TWOD-ARRAY 10 (0)) (GENERAL-ARRAY 10 (
0 8)) (BIGNUM) (RATIO) (COMPLEX) (PATHNAME) (NEW-ATOM 10 (2 4 6)) (FILLER22) (FILLER23) (FILLER24) (
FILLER25) (FILLER26) (FILLER27) (FILLER28) (FILLER29) (FILLER30)))
(BLOCKRECORD DTD ((NIL BITS 2) (DTDOBSOLETE FLAG) (* \; 
"True for type of a redeclared datatype--not allowed to allocate more of these") (DTDFINALIZABLE FLAG)
 (* \; "True if finalization exists for this type") (DTDNAME POINTER) (* \; "Type name -- a symbol ") 
(DTDCNT0 WORD) (* \; "Incremental box count -- this plus DTDOLDCNT is the true box count") (DTDSIZE 
WORD) (* \; "Length of datum in words") (DTDFREE FULLXPOINTER) (* \; 
"Pointer to first object on free chain, or NIL.  Not used for LISTP") (DTDLOCKEDP FLAG) (* \; 
"True if objects of this type must be locked down (not pagefault)") (DTDHUNKP FLAG) (* \; 
"True if this type is used as an array hunk type") (DTDGCTYPE BITS 2) (* \; 
"For hunk datatypes, is analogous to arrayblock's GCTYPE") (DTDDESCRS POINTER) (DTDTYPESPECS POINTER) 
(DTDPTRS POINTER) (* \; 
"List of word offsets inside datum where reference-counted pointers are stored -- used by GC") (
DTDOLDCNT FIXP) (* \; "'Box count' -- number of objects of this type ever allocated") (DTDNEXTPAGE 
FIXP) (* \; 
"Currently only for LISTP pages -- page number of next page on chain of non-full cons pages") (
DTDTYPEENTRY WORD) (* |;;| 
"The word stored in the type table for objects of this type.  Hi bits have numberp tags, ref countable, etc."
) (DTDSUPERTYPE WORD) (* \; "Type number of immediate supertype, or zero if none")) (ACCESSFNS DTD ((
DTDCNTLOC (\\ADDBASE DATUM 4)) (DTDCNT (IPLUS (|fetch| DTDOLDCNT DATUM) (|fetch| DTDCNT0 DATUM)) (
UNINTERRUPTABLY (|replace| DTDOLDCNT |of| DATUM |with| NEWVALUE) (|replace| DTDCNT0 |of| DATUM |with| 
0))))))
(PUTPROPS \\GETDTD MACRO ((|typeNum|) (ADDBASE |\\DTDSpaceBase| (ITIMES |typeNum| 18))))
(DEFOPTIMIZER \\TYPEMASK.UFN (&REST X) (LET ((CE (CONSTANTEXPRESSIONP (CADR X)))) (|if| CE |then| (
BQUOTE ((OPCODES TYPEMASK.N (\\\, (CAR CE))) (\\\, (CAR X)))) |else| (QUOTE IGNOREMACRO))))
(RPAQQ \\GUARDSTORAGEFULL 128)
(RPAQQ \\GUARD1STORAGEFULL 64)
(CONSTANTS \\GUARDSTORAGEFULL \\GUARD1STORAGEFULL)
(GLOBALVARS |\\NxtMDSPage| |\\LeastMDSPage| |\\SecondArrayPage| |\\SecondMDSPage| \\MDSFREELISTPAGE 
|\\MaxSysTypeNum| |\\MaxTypeNumber| \\STORAGEFULL \\INTERRUPTSTATE \\PENDINGINTERRUPT)
(PUTPROP (QUOTE LLDATATYPE) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:57:50"))

(ACCESSFNS POINTER ((PAGE# (IPLUS (LLSH (\\HILOC DATUM) 8) (LRSH (\\LOLOC DATUM) 8))) (WORDINPAGE (
LOGAND (\\LOLOC DATUM) 255)) (CELLINPAGE (LRSH (|fetch| WORDINPAGE |of| DATUM) 1)) (BYTEINPAGE (LLSH (
|fetch| WORDINPAGE |of| DATUM) 1)) (SEGMENT# (\\HILOC DATUM)) (WORDINSEGMENT (\\LOLOC DATUM)) (
CELLINSEGMENT (LRSH (|fetch| WORDINSEGMENT |of| DATUM) 1)) (WORD# (|fetch| WORDINPAGE |of| DATUM)) (
DBLWORD# (|fetch| CELLINPAGE |of| DATUM)) (PAGEBASE (\\VAG2 (\\HILOC DATUM) (LOGAND (\\LOLOC DATUM) 
65280)))) (CREATE (\\VAG2 (LRSH PAGE# 8) (LLSH (LOGAND PAGE# 255) 8))))
(ACCESSFNS WORD ((HIBYTE (LRSH DATUM 8)) (LOBYTE (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH HIBYTE 8) 
LOBYTE)))
(PUTPROPS PTRGTP MACRO (OPENLAMBDA (X Y) (OR (IGREATERP (\\HILOC X) (\\HILOC Y)) (AND (EQ (\\HILOC X) 
(\\HILOC Y)) (IGREATERP (\\LOLOC X) (\\LOLOC Y))))))
(PUTPROPS .COERCE.TO.SMALLPOSP. DMACRO (OPENLAMBDA (X) (COND ((SMALLPOSP X) X) (T (\\ILLEGAL.ARG X))))
)
(PUTPROPS .COERCE.TO.BYTE. DMACRO (OPENLAMBDA (X) (COND ((AND (SMALLPOSP X) (ILESSP X (CONSTANT (LLSH 
1 BITSPERBYTE)))) X) (T (\\ILLEGAL.ARG X)))))
(BLOCKRECORD LISTP ((* |;;| "Describes a CONS cell.") (CAR POINTER) (CDR POINTER)) (CREATE (CREATECELL
 \\LISTP)) (* |;;| "FOLLOWING ARE CDR-CODE FIELDS") (BLOCKRECORD LISTP ((CDRCODE BITS 4) (CARFIELD 
XPOINTER))) (* |;;| "For chaining together free cells on a page:") (BLOCKRECORD LISTP ((NEXTFREE BYTE)
 (NIL BITS 24))) (ACCESSFNS LISTP ((FULLCARFIELD NIL (\\PUTBASEPTR DATUM 0 NEWVALUE)))) (* |;;| 
"because replace of XPOINTER is slow, the CAR field is stored with PUTBASEPTR, even though that smashes the hi byte"
))
(BLOCKRECORD CONSPAGE ((* |;;| 
"Describes a page of CONS cells, which (when free) are chained together thru the top byte.") (NIL 2 
FIXP) (* \; "Empty cells, space for another 2 CONS cells if we can figure out how.") (CNT BYTE) (* \; 
"# of cells free on this page") (NEXTCELL BYTE) (* \; 
"WORD offset of next free cell (not guaranteed to be 0 if no free cells)") (NIL WORD) (* \; "Padding")
 (NEXTPAGE FIXP) (* \; "Next CONS page on the DTD's free list, for searching for cells.")))
(RPAQQ CONSCONSTANTS (\\CDR.ONPAGE \\CDR.NIL \\CDR.INDIRECT \\CDR.MAXINDIRECT \\CONSPAGE.LAST))
(RPAQQ \\CDR.ONPAGE 8)
(RPAQQ \\CDR.NIL 8)
(RPAQQ \\CDR.INDIRECT 0)
(RPAQQ \\CDR.MAXINDIRECT 7)
(RPAQQ \\CONSPAGE.LAST 65535)
(CONSTANTS \\CDR.ONPAGE \\CDR.NIL \\CDR.INDIRECT \\CDR.MAXINDIRECT \\CONSPAGE.LAST)
(PUTPROPS LOCAL MACRO ((X) X))
(PUTPROPS ALLOCAL MACRO ((X) X))
(PUTPROP (QUOTE LLNEW) (QUOTE IMPORTDATE) (IDATE " 2-Feb-1995 16:21:44"))

(PUTPROPS CHECK MACRO (ARGS (COND ((AND (BOUNDP (QUOTE CHECK)) CHECK) (CONS (QUOTE PROGN) (|for| I 
|in| ARGS |collect| (LIST (QUOTE OR) I (LIST (QUOTE RAID) (KWOTE (LIST (QUOTE |Check-failure:|) I)))))
)) (T (CONS COMMENTFLG ARGS)))))
(PUTPROPS |\\StatsZero| BYTEMACRO (OPENLAMBDA (N) (\\PUTBASE N 0 0) (\\PUTBASE N 1 0)))
(PUTPROPS |\\StatsAdd1| DMACRO (OPENLAMBDA (A) (PROG ((LO (IPLUS16 (\\GETBASE A 1) 1))) (DECLARE (
LOCALVARS LO)) (* \; "Increment double word at A by 1") (\\PUTBASE A 1 LO) (COND ((EQ LO 0) (\\PUTBASE
 A 0 (ADD1 (\\GETBASE A 0))))))))
(PUTPROPS IPLUS16 MACRO ((X Y) (* \; "Kludge to do 16-bit plus") (\\LOLOC (\\ADDBASE X Y))))
(PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0))))
(PROGN (PUTPROPS SETXVAR MACRO (X (BQUOTE (SETQ.NOREF \, (CADAR X) \, (CADR X))))) (PUTPROPS SETXVAR 
DMACRO (X (OR (AND (EQ (CAAR X) (QUOTE QUOTE)) (LITATOM (CADAR X))) (SHOULDNT)) (GLOBALVARS \\VALSPACE
) (LIST (QUOTE SETQ.NOREF) (CADAR X) (CADR X)))))
(PUTPROPS SETQ.NOREF DMACRO ((VAR VAL) (\\PUTBASEPTR (LOCF (|fetch| (LITATOM VALUE) |of| (QUOTE VAR)))
 0 VAL)))
(PROGN (PUTPROPS IEQ MACRO ((X Y) (IEQP X Y))) (PUTPROPS IEQ DMACRO (= . EQ)))
(RPAQQ |WordsPerPage| 256)
(CONSTANTS |WordsPerPage|)
(ACCESSFNS LITATOM ((DEFINITIONCELL (\\DEFCELL DATUM)) (PROPCELL (\\PROPCELL DATUM)) (VCELL (\\VALCELL
 DATUM)) (PNAMECELL (\\PNAMECELL DATUM))) (* |;;| 
"VCELL can also be accessed directly from a value index via the record VALINDEX (as in \\SETGLOBALVAL.UFN) --- Similarly, PNAMEINDEX accesses PNAMECELL for use by \\MKATOM and UNCOPYATOM"
) (TYPE? (LITATOM DATUM)) (BLOCKRECORD PROPCELL ((NIL BITS 4) (* \; "former flags locations") (
PROPLIST POINTER) (NIL BITS 8) (* \; "Package byte") (NIL BITS 8) (* \; "Flags from defcell") (* |;;| 
"PROPCell flags:") (NIL BITS 1) (GENSYMP FLAG) (FATPNAMEP FLAG) (NIL BITS 5) (* |;;| 
"Filler for final cell:") (NIL BITS 8))))
(SYNONYM CL:SYMBOL (LITATOM))
(ACCESSFNS VALINDEX ((VCELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* \; 
"Xerox Lisp traditional symbol") (\\ADDBASE2 \\PNPSPACE (IPLUS \\NEWATOM-VALOFFSET (ITIMES 10 DATUM)))
) (T (* \; "New symbol") (* \; "'90/07/19 ON") (\\ADDBASE DATUM \\NEWATOM-VALOFFSET))))))
(BLOCKRECORD VCELL ((VALUE FULLPOINTER)))
(BLOCKRECORD DEFINITIONCELL ((CCODEP FLAG) (FASTP FLAG) (ARGTYPE BITS 2) (* \; "Former flag location")
 (DEFPOINTER POINTER) (NIL POINTER) (* \; "Proplist cell") (NIL BITS 8) (* \; "package") (* |;;| 
"DEFCELL flags overflow from top 4 bits of the real cell:") (NIL BITS 4) (PSEUDOCODEP FLAG) (NIL BITS 
3) (* |;;| "proplist falgs and filler:") (NIL BITS 16)) (BLOCKRECORD DEFINITIONCELL ((DEFCELLFLAGS 
BITS 4) (NIL POINTER) (* \; "defn ptr") (NIL BITS 4) (NIL POINTER) (* \; "filler for proplist ptr") (
NIL BITS 8) (AUXDEFCELLFLAGS BYTE) (NIL BITS 16))))
(BLOCKRECORD FNHEADER ((STKMIN WORD) (NA SIGNEDWORD) (PV SIGNEDWORD) (STARTPC WORD) (CLOSUREP FLAG) (*
 \; "T if this is a \"compiled closure\"") (BYTESWAPPED FLAG) (* \; 
"T if, on 386, we reswapped the code section of this function for faster access.") (ARGTYPE BITS 2) (*
 \; "0 = LAMBDA") (* \; "2 = LAMBDA nospread") (* \; "1 = NLAMBDA") (* \; "3 = NLAMBDA nospread") (* 
|;;| "4 NIL BITS USED TO BE HERE.") (\#FRAMENAME XPOINTER) (NTSIZE WORD) (* \; 
"Size of the Name Table, IN WORDS.  This value is always rounded up to the next Quad-word in size, and there' guaranteed to be one entry of zeros in the length."
) (NLOCALS BYTE) (FVAROFFSET BYTE)) (ACCESSFNS FNHEADER ((LSTARP (ILESSP (|fetch| (FNHEADER NA) |of| 
DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (NATIVE (PROGN NIL)) (* \; 
"T if this is a NATIVE-code function (never true!)") (ALIGNED (IPLUS (|fetch| (FNHEADER NTSIZE) |of| 
DATUM) (|fetch| (FNHEADER OVERHEADWORDS) |of| T))) (FIXED NIL (|replace| (FNHEADER STKMIN) |of| DATUM 
|with| (\\STKMIN DATUM T))) (NPVARWORDS (UNFOLD (ADD1 (|fetch| (FNHEADER PV) |of| DATUM)) WORDSPERQUAD
)) (FRAMENAME (|fetch| (FNHEADER \#FRAMENAME) |of| DATUM) (UNINTERRUPTABLY (CHECK (NEQ (\\HILOC DATUM)
 \\STACKHI)) (\\DELREF (|fetch| (FNHEADER \#FRAMENAME) |of| DATUM)) (\\ADDREF NEWVALUE) (|replace| (
FNHEADER \#FRAMENAME) |of| DATUM |with| NEWVALUE))))))
(BLOCKRECORD PNAMECELL ((NIL BITS 4) (PNAMEBASE XPOINTER) (NIL POINTER) (* \; "val, def, prop cells") 
(NIL POINTER) (NIL POINTER) (PACKAGEINDEX BYTE) (NIL BITS 24) (* \; "filler for other flags")) (
BLOCKRECORD PNAMECELL ((FULLPNAMEBASE FULLXPOINTER) (* \; "Replacing this smashes PACKAGEINDEX to 0"))
) (ACCESSFNS PNAMECELL ((PACKAGE (LET ((I (FETCH (PNAMECELL PACKAGEINDEX) OF DATUM))) (* \; 
"This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound."
) (COND ((EQ 0 I) NIL) (T (CL:AREF *PACKAGE-FROM-INDEX* I)))) (REPLACE (PNAMECELL PACKAGEINDEX) OF 
DATUM WITH (IF (NULL NEWVALUE) THEN *UNINTERNED-PACKAGE-INDEX* ELSE (CL::%PACKAGE-INDEX NEWVALUE))))))
)
(ACCESSFNS PACKAGEINDEX ((PACKAGE (IF (EQ 0 DATUM) (* \; 
"This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound."
) THEN NIL ELSE (CL:AREF *PACKAGE-FROM-INDEX* DATUM)))))
(BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE) (* \; "Length is always here, be the pname thin or fat") (
PNAMEFATPADDINGBYTE BYTE) (* \; 
"This byte is zero for fat pnames so that the pname chars are word-aligned")))
(ACCESSFNS PNAMEINDEX ((PNAMECELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* \; 
"Xerox Lisp traditional symbol") (\\ADDBASE \\OLDATOMSPACE (IPLUS \\NEWATOM-PNAMEOFFSET (ITIMES 10 
DATUM)))) (T (* \; "New symbol") (* \; "'90/07/19 ON") (\\ADDBASE DATUM \\NEWATOM-PNAMEOFFSET))))))
(BLOCKRECORD NEW-ATOM ((* |;;| 
"An extended symbol, for expanding atom space.  Kept in its own datatype.") (PNAME XPOINTER) (* \; 
"PNAME, same as litatom.") (VALUE POINTER) (DEF POINTER) (PROPLIST POINTER) (* |;;| 
"Flags that used to be above the pointers, e.g. package, ccodep, gensymp:") (NIL BITS 32)))
(PUTPROPS \\DEFCELL MACRO ((ATOM) (\\ATOMCELL ATOM \\DEF.HI)))
(PUTPROPS \\VALCELL MACRO ((ATOM) (\\ATOMCELL ATOM \\VAL.HI)))
(PUTPROPS \\PNAMECELL MACRO ((ATOM) (\\ATOMCELL ATOM \\PNAME.HI)))
(PUTPROPS \\ATOMVALINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; 
"Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (
SHOULDNT)))))
(PUTPROPS \\ATOMDEFINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; 
"Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (
SHOULDNT)))))
(PUTPROPS \\ATOMPNAMEINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; 
"Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (
SHOULDNT)))))
(PUTPROPS \\ATOMPROPINDEX DMACRO ((X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") (
\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (SHOULDNT)))))
(PUTPROPS \\INDEXATOMPNAME DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; 
"Xerox Lisp traditional symbol") (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (
LOGAND X 65535))))) (T (* \; "New symbol") X))))
(PUTPROPS \\INDEXATOMVAL DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol")
 (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* \; 
"New symbol") X))))
(PUTPROPS \\INDEXATOMDEF DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol")
 (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* \; 
"New symbol") X))))
(PUTPROPS \\ATOMNUMBER DMACRO (= . \\LOLOC))
(GLOBALVARS |\\NxtPnByte| |\\CurPnPage| |\\NxtAtomPage| |\\AtomFrLst| |\\OneCharAtomBase| 
\\PNAMES.IN.BLOCKS? \\SCRATCHSTRING COMPILEATPUTDFLG)
(RPAQQ \\PNAMELIMIT 255)
(RPAQQ |\\CharsPerPnPage| 512)
(CONSTANTS (\\PNAMELIMIT 255) (|\\CharsPerPnPage| 512))
(RPAQQ \\NEWATOM-PNAMEOFFSET 0)
(RPAQQ \\NEWATOM-VALOFFSET 2)
(RPAQQ \\NEWATOM-DEFOFFSET 4)
(RPAQQ \\NEWATOM-PLISTOFFSET 6)
(RPAQQ \\NEWATOM-TYPE# 21)
(CONSTANTS (\\NEWATOM-PNAMEOFFSET 0) (\\NEWATOM-VALOFFSET 2) (\\NEWATOM-DEFOFFSET 4) (
\\NEWATOM-PLISTOFFSET 6) (\\NEWATOM-TYPE# 21))
(PUTPROPS \\MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) (\\BLT (\\ADDBASE DBASE 
DOFFSET) (\\ADDBASE SBASE SOFFSET) NWORDS)))
(PUTPROP (QUOTE LLBASIC) (QUOTE IMPORTDATE) (IDATE "31-Jan-1998 09:55:50"))

(ACCESSFNS STRINGP ((XREADONLY (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| DATUM) (|replace| (
ARRAY-HEADER READ-ONLY-P) |of| DATUM |with| NEWVALUE)) (XBASE ((OPENLAMBDA (STRING) (COND ((|fetch| (
ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-BASE STRING)) (T (|fetch| (ARRAY-HEADER BASE) |of| 
STRING)))) DATUM) ((OPENLAMBDA (STRING NV) (|replace| (ARRAY-HEADER INDIRECT-P) |of| STRING |with| NIL
) (|replace| (ARRAY-HEADER BASE) |of| STRING |with| NV) NV) DATUM NEWVALUE)) (TYP ((OPENLAMBDA (STRING
) (SELECTC (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-TYPE-NUMBER STRING)) (T (
|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| STRING))) (%THIN-CHAR-TYPENUMBER \\ST.BYTE) (
%FAT-CHAR-TYPENUMBER \\ST.POS16) (SHOULDNT "Unknown type-number"))) DATUM) ((OPENLAMBDA (STRING NV) (
LET ((%NEW-TYPE-NUMBER (SELECTC NV (\\ST.BYTE %THIN-CHAR-TYPENUMBER) (\\ST.POS16 %FAT-CHAR-TYPENUMBER)
 (SHOULDNT "Unknown typ value")))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (
%SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| STRING 
|with| %NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (LENGTH (|fetch| (ARRAY-HEADER FILL-POINTER) |of| DATUM)
 ((OPENLAMBDA (STRING NV) (|replace| (ARRAY-HEADER FILL-POINTER) |of| STRING |with| NV) (|replace| (
ARRAY-HEADER TOTAL-SIZE) |of| STRING |with| NV) (COND ((%GENERAL-ARRAY-P STRING) (|freplace| (
GENERAL-ARRAY DIMS) |of| STRING |with| (LIST NV)))) NV) DATUM NEWVALUE)) (OFFST ((OPENLAMBDA (STRING) 
(COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-OFFSET STRING)) (T (|fetch| (
ARRAY-HEADER OFFSET) |of| STRING)))) DATUM) ((OPENLAMBDA (STRING NV) (COND ((NOT (EQ 0 NV)) (|replace|
 (ARRAY-HEADER DISPLACED-P) |of| STRING |with| T))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| 
STRING) (%SET-ARRAY-OFFSET STRING NV)) (T (|replace| (ARRAY-HEADER OFFSET) |of| STRING |with| NV)))) 
DATUM NEWVALUE)) (* |;;| "The rest of these fields only appear when smashing") (XFLAGS (LOGAND (
|fetch| (ARRAY-HEADER FLAGS) |of| DATUM) 15) ((OPENLAMBDA (STRING) (|replace| (ARRAY-HEADER 
ADJUSTABLE-P) |of| STRING |with| NIL) (|replace| (ARRAY-HEADER DISPLACED-P) |of| STRING |with| NIL) (
|replace| (ARRAY-HEADER FILL-POINTER-P) |of| STRING |with| NIL) (|replace| (ARRAY-HEADER EXTENDABLE-P)
 |of| STRING |with| NIL)) DATUM))) (ACCESSFNS STRINGP ((ORIG ((OPENLAMBDA (STRING) 1) DATUM) ((
OPENLAMBDA (STRING NV) (COND ((NOT (EQ NV 1)) (ERROR "Il:stringp's are always origin 1"))) NV) DATUM 
NEWVALUE)) (* \; "An inoperative field") (SUBSTRINGED ((OPENLAMBDA (STRING) NIL) DATUM) ((OPENLAMBDA (
STRING NV) (OR (NULL NV) (ERROR "Substringed field not supported"))) DATUM NEWVALUE)) (READONLY (
|ffetch| (STRINGP XREADONLY) |of| DATUM) (|freplace| (STRINGP XREADONLY) |of| DATUM |with| NEWVALUE)) 
(FATSTRINGP ((OPENLAMBDA (STRING) (EQ (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (
%ARRAY-TYPE-NUMBER STRING)) (T (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| STRING))) %FAT-CHAR-TYPENUMBER
)) DATUM) ((OPENLAMBDA (STRING NV) (LET ((%NEW-TYPE-NUMBER (COND (NV %FAT-CHAR-TYPENUMBER) (T 
%THIN-CHAR-TYPENUMBER)))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (
%SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| STRING 
|with| %NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (BASE (|ffetch| (STRINGP XBASE) |of| DATUM) (|freplace| 
(STRINGP XBASE) |of| DATUM |with| NEWVALUE)))) (CREATE (|create| ONED-ARRAY BASE _ XBASE READ-ONLY-P _
 XREADONLY STRING-P _ T DISPLACED-P _ (NOT (EQ OFFST 0)) TYPE-NUMBER _ (COND ((EQ TYP \\ST.POS16) 
%FAT-CHAR-TYPENUMBER) (T %THIN-CHAR-TYPENUMBER)) OFFSET _ OFFST FILL-POINTER _ LENGTH TOTAL-SIZE _ 
LENGTH)) (TYPE? (CL:STRINGP DATUM)) OFFST _ 0 TYP _ \\ST.BYTE LENGTH _ 0)
(GLOBALVARS |\\OneCharAtomBase|)
(PUTDEF (QUOTE \\NUMSTR) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING 128))))
(PUTDEF (QUOTE \\NUMSTR1) (QUOTE RESOURCES) (QUOTE (NEW (CONCAT))))
(PUTDEF (QUOTE \\PNAMESTRING) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING \\PNAMELIMIT NIL NIL 
\\FATPNAMESTRINGP))))
(RPAQQ \\FATPNAMESTRINGP T)
(CONSTANTS (\\FATPNAMESTRINGP T))
(PUTPROPS \\PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* \; 
"For stuffing chars into resource \\PNAMESTRING") (\\PUTBASECHAR \\FATPNAMESTRINGP BASE OFFSET CODE)))
(DEFOPTIMIZER FCHARACTER (NUM) (BQUOTE ((OPENLAMBDA (N) (COND ((IGREATERP N \\MAXTHINCHAR) (* \; 
"The character we're getting is NOT a thin character -- do it the hard way") (CHARACTER N)) ((
IGREATERP N (CHARCODE 9)) (\\ADDBASE |\\OneCharAtomBase| (IDIFFERENCE N 10))) ((IGEQ N (CHARCODE 0)) (
IDIFFERENCE N (CHARCODE 0))) (T (* \; "The common case -- just add on the one-atom base.") (\\ADDBASE 
|\\OneCharAtomBase| N)))) (\\\, NUM))))
(I.S.OPR (QUOTE |inpname|) NIL (QUOTE (SUBPAIR (QUOTE ($$END $$BODY $$FATP $$BASE $$OFFSET)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (BQUOTE (|bind| $$OFFSET _ 0 
$$BODY _ BODY $$BASE $$END $$FATP |declare| (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET) |first| (
PROG NIL $$RETRY (COND ((STRINGP $$BODY) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ 
$$OFFSET (SUB1 (|ffetch| (STRINGP OFFST) |of| $$BODY))) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP
 LENGTH) |of| $$BODY))) (SETQ $$FATP (|ffetch| (STRINGP FATSTRINGP) |of| $$BODY))) ((LITATOM $$BODY) (
SETQ $$BASE (|ffetch| (LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) 
|of| $$BASE)) (SETQ $$FATP (|ffetch| (LITATOM FATPNAMEP) |of| $$BODY))) (T (SETQ $$BODY (MKSTRING 
$$BODY)) (GO $$RETRY)))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (
GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET)
))))))) T)
(I.S.OPR (QUOTE |inatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END $$FATP)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 
$$BODY _ BODY $$BASE $$END $$FATP |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP) |first| (
SETQ $$BASE (|ffetch| (LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) 
|of| $$BASE)) (SETQ $$FATP (|ffetch| (LITATOM FATPNAMEP) |of| $$BODY)) |eachtime| (SETQ $$OFFSET (ADD1
 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE 
$$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET)))))))) T)
(I.S.OPR (QUOTE |instring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE $$FATP)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY 
$$END $$OFFSET $$BASE $$FATP |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP) |first| (SETQ 
$$OFFSET (SUB1 (|ffetch| (STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| 
$$BODY)) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) (SETQ $$FATP (|ffetch| 
(STRINGP FATSTRINGP) |of| $$BODY)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET
 $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE 
$$OFFSET)))))))) T)
(I.S.OPR (QUOTE |infatatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY 
$$BASE $$END |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END) |first| (SETQ $$BASE (|ffetch| (
LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) 
|eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (
\\GETBASEFAT $$BASE $$OFFSET)))))) T)
(I.S.OPR (QUOTE |inthinatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY 
$$BASE $$END |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END) |first| (SETQ $$BASE (|ffetch| (
LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) 
|eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (
\\GETBASETHIN $$BASE $$OFFSET)))))) T)
(I.S.OPR (QUOTE |infatstring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET 
$$BASE |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE) |first| (SETQ $$OFFSET (SUB1 (|ffetch| (
STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS 
$$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (
IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\\GETBASEFAT $$BASE $$OFFSET)))))) T)
(I.S.OPR (QUOTE |inthinstring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET 
$$BASE |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE) |first| (SETQ $$OFFSET (SUB1 (|ffetch| (
STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS 
$$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (
IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\\GETBASETHIN $$BASE $$OFFSET)))))) T)
(PUTPROPS \\CHARCODEP DMACRO (OPENLAMBDA (X) (* \; 
"used to also say (ILEQ X \\MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X)
 (IGEQ X 0))))
(PUTPROPS \\FATCHARCODEP DMACRO (OPENLAMBDA (X) (* \; 
"Used to also say (ILEQ X \\MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X)
 (IGREATERP X \\MAXTHINCHAR))))
(PUTPROPS \\THINCHARCODEP DMACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0) (ILEQ X \\MAXTHINCHAR))))
(PUTPROPS \\GETBASEFAT MACRO (= . \\GETBASE))
(PUTPROPS \\GETBASETHIN MACRO (= . \\GETBASEBYTE))
(PUTPROPS \\PUTBASEFAT MACRO (= . \\PUTBASE))
(PUTPROPS \\PUTBASETHIN MACRO (= . \\PUTBASEBYTE))
(PUTPROPS \\PUTBASECHAR MACRO (OPENLAMBDA (FATP BASE OFFSET CODE) (COND (FATP (\\PUTBASEFAT BASE 
OFFSET CODE)) (T (\\PUTBASETHIN BASE OFFSET CODE)))))
(PUTPROPS \\GETBASECHAR MACRO ((FATP BASE N) (COND (FATP (\\GETBASEFAT BASE N)) (T (\\GETBASETHIN BASE
 N)))))
(PUTPROPS \\CHARSET MACRO ((CHARCODE) (LRSH CHARCODE 8)))
(PUTPROPS \\CHAR8CODE MACRO ((CHARCODE) (LOGAND CHARCODE 255)))
(RPAQQ \\CHARMASK 255)
(RPAQQ \\MAXCHAR 255)
(RPAQQ \\MAXTHINCHAR 255)
(RPAQQ \\MAXFATCHAR 65535)
(RPAQQ \\MAXCHARSET 255)
(RPAQQ NSCHARSETSHIFT 255)
(RPAQQ \#STRINGPWORDS 4)
(CONSTANTS (\\CHARMASK 255) (\\MAXCHAR 255) (\\MAXTHINCHAR 255) (\\MAXFATCHAR 65535) (\\MAXCHARSET 255
) (NSCHARSETSHIFT 255) (\#STRINGPWORDS 4))
(PUTPROPS \\NATOMCHARS DMACRO ((AT) (|fetch| (LITATOM PNAMELENGTH) |of| AT)))
(PUTPROPS \\NSTRINGCHARS DMACRO ((S) (|fetch| (STRINGP LENGTH) |of| S)))
(PUTPROP (QUOTE LLCHAR) (QUOTE IMPORTDATE) (IDATE "11-Nov-2018 13:08:04"))

(ACCESSFNS BF ((BFBLOCK (ADDSTACKBASE DATUM))) (* \; "basic frame pointer") (BLOCKRECORD BFBLOCK ((
FLAGS BITS 3) (NIL BITS 3) (RESIDUAL FLAG) (* \; "true if this is not a full BF") (PADDING BITS 1) (
USECNT BITS 8) (IVAR WORD))) (TYPE? (IEQ (|fetch| (BF FLAGS) |of| DATUM) \\STK.BF)) (ACCESSFNS BF ((
NARGS (IDIFFERENCE (FOLDLO (IDIFFERENCE DATUM (|fetch| (BF IVAR) |of| DATUM)) WORDSPERCELL) (|fetch| (
BF PADDING) |of| DATUM))) (SIZE (IPLUS 2 (IDIFFERENCE DATUM (|fetch| (BF IVAR) |of| DATUM)))) (CHECKED
 (AND (|type?| BF DATUM) (|for| I |from| (|fetch| (BF IVAR) |of| DATUM) |to| (IDIFFERENCE DATUM 2) 
|by| 2 |always| (IEQ \\STK.NOTFLAG (|fetch| (BF FLAGS) |of| I))))))))
(ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* \; "frame extension index") (BLOCKRECORD FXBLOCK ((
FLAGS BITS 3) (* \; "= \\STK.FX") (FAST FLAG) (NIL FLAG) (INCALL FLAG) (* \; 
"set when fncall microcode has to punt") (VALIDNAMETABLE FLAG) (* \; 
"if on, NAMETABLE field is filled in.  If off, is same as FNHEADER") (NOPUSH FLAG) (* \; 
"when returning to this frame, don't push a value.  Set by interrupt code") (USECNT BITS 8) (\#ALINK 
WORD) (* \; "low bit is SLOWP") (FNHEADER FULLXPOINTER) (NEXTBLOCK WORD) (PC WORD) (NAMETABLE# 
FULLXPOINTER) (\#BLINK WORD) (\#CLINK WORD))) (BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE) (NIL BYTE) (NIL 
BITS 15) (* \; "most of the bits of #ALINK") (SLOWP FLAG) (* \; 
"if on, then BLINK and CLINK fields are valid.  If off, they are implicit") (NIL FULLXPOINTER 2) (
NAMETABHI WORD) (NAMETABLO WORD))) (TYPE? (IEQ (|fetch| (FX FLAGS) |of| DATUM) \\STK.FX)) (ACCESSFNS 
FX ((NAMETABLE (COND ((|fetch| (FX VALIDNAMETABLE) |of| DATUM) (|fetch| (FX NAMETABLE#) |of| DATUM)) (
T (|fetch| (FX FNHEADER) |of| DATUM))) (PROGN (|replace| (FX FAST) |of| DATUM |with| NIL) (|replace| (
FX NAMETABLE#) |of| DATUM |with| NEWVALUE) (|replace| (FX VALIDNAMETABLE) |of| DATUM |with| T))) (
FRAMENAME (|fetch| (FNHEADER FRAMENAME) |of| (|fetch| (FX NAMETABLE) |of| DATUM))) (INVALIDP (EQ DATUM
 0)) (* \; "true when A/CLink points at nobody, i.e. FX is bottom of stack") (FASTP (NOT (|fetch| (FX 
SLOWP) |of| DATUM)) (PROGN (CHECK (NULL NEWVALUE)) (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (
FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX \#CLINK) |of| DATUM 
|with| (|fetch| (FX \#ALINK) |of| DATUM)) (|replace| (FX SLOWP) |of| DATUM |with| T))))) (BLINK (COND 
((|fetch| (FX FASTP) |of| DATUM) (|fetch| (FX DUMMYBF) |of| DATUM)) (T (|fetch| (FX \#BLINK) |of| 
DATUM))) (PROGN (|replace| (FX \#BLINK) |of| DATUM |with| NEWVALUE) (COND ((|fetch| (FX FASTP) |of| 
DATUM) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX \#ALINK) |of| DATUM)) (|replace| (FX 
SLOWP) |of| DATUM |with| T))))) (CLINK (IDIFFERENCE (COND ((|fetch| (FX FASTP) |of| DATUM) (|fetch| (
FX \#ALINK) |of| DATUM)) (T (|fetch| (FX \#CLINK) |of| DATUM))) \\#ALINK.OFFSET) (PROGN (|replace| (FX
 \#CLINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET)) (COND ((|fetch| (FX FASTP) |of| DATUM) (
|replace| (FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX SLOWP) |of|
 DATUM |with| T))))) (ALINK (IDIFFERENCE (FLOOR (|fetch| (FX \#ALINK) |of| DATUM) WORDSPERCELL) 
\\#ALINK.OFFSET) (PROGN (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX \#BLINK) |of| DATUM 
|with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX 
\#ALINK) |of| DATUM)))) (|replace| (FX \#ALINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET (
SUB1 WORDSPERCELL))))) (ACLINK (SHOULDNT) (PROGN (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX
 \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)))) (|replace| (FX \#CLINK) |of| DATUM 
|with| (IPLUS NEWVALUE \\#ALINK.OFFSET)) (|replace| (FX \#ALINK) |of| DATUM |with| (IPLUS NEWVALUE 
\\#ALINK.OFFSET (SUB1 WORDSPERCELL))))) (* \; 
"replaces A & C Links at once more efficiently than separately") (DUMMYBF (IDIFFERENCE DATUM 
WORDSPERCELL)) (* |;;| 
"This is either an actual BF or \"residual\" BF that provides enough BF to find its IVAR slot.  This means that when a FX is copied, the cell preceding the FX is copied too."
) (IVAR (|fetch| (BF IVAR) |of| (|fetch| (FX DUMMYBF) |of| DATUM))) (CHECKED (AND (|type?| FX DATUM) (
OR (IEQ (|fetch| (FX DUMMYBF) |of| DATUM) (|fetch| (FX BLINK) |of| DATUM)) (AND (|fetch| (BF RESIDUAL)
 |of| (|fetch| (FX DUMMYBF) |of| DATUM)) (IEQ (|fetch| (BF IVAR) |of| (|fetch| (FX DUMMYBF) |of| DATUM
)) (|fetch| (BF IVAR) |of| (|fetch| (FX BLINK) |of| DATUM))))))) (FIRSTPVAR (IPLUS DATUM (|fetch| (FX 
FXSIZE) |of| T))) (* \; "stack offset of PVAR0") (FXSIZE (PROGN 10)) (* \; 
"fixed overhead from flags thru clink") (PADDING (PROGN 4)) (* \; 
"doublecell of garbage for microcode use") (FIRSTTEMP (IPLUS (|fetch| (FX FIRSTPVAR) |of| DATUM) (
|fetch| (FX NPVARWORDS) |of| DATUM) (|fetch| (FX PADDING) |of| DATUM))) (* \; 
"note that NPVARWORDS is obtained from the FNHEADER") (SIZE (IDIFFERENCE (|fetch| (FX NEXTBLOCK) |of| 
DATUM) DATUM)))))
(ACCESSFNS FSB (* |;;| "FREE STACK BLOCK -- ") (* |;;| " A piece of stack space that's free.") (* |;;|
 "The first word contains 120000Q") (* |;;| "The 2nd word is the size of the block, in words.") ((
FSBBLOCK (ADDSTACKBASE DATUM)) (CHECKED (IEQ (|fetch| (FSB FLAGWORD) |of| DATUM) \\STK.FSB.WORD))) (
BLOCKRECORD FSBBLOCK ((FLAGS BITS 3) (DUMMY BITS 13) (SIZE WORD))) (BLOCKRECORD FSBBLOCK ((FLAGWORD 
WORD) (SIZE WORD))) (* \; "free stack block") (TYPE? (IEQ (|fetch| (FSB FLAGS) |of| DATUM) \\STK.FSB))
)
(ACCESSFNS STK ((STKBLOCK (ADDSTACKBASE DATUM))) (* \; "unspecified stack block") (BLOCKRECORD 
STKBLOCK ((FLAGS BITS 3))) (BLOCKRECORD STKBLOCK ((FLAGWORD WORD))))
(RPAQQ \\#ALINK.OFFSET 10)
(CONSTANTS \\#ALINK.OFFSET)
(GLOBALVARS \\PENDINGINTERRUPT \\KBDSTACKBASE \\MISCSTACKBASE \\STACKOVERFLOW)
(PUTPROPS \\MYALINK DMACRO (NIL ((OPCODES MYALINK))))
(PUTPROPS ADDSTACKBASE DMACRO (= . STACKADDBASE))
(PUTPROPS STACKADDBASE DMACRO ((N) (VAG2 \\STACKHI N)))
(PUTPROPS STACKGETBASE DMACRO ((N) (\\GETBASE (STACKADDBASE N) 0)))
(PUTPROPS STACKGETBASEPTR DMACRO ((N) (\\GETBASEPTR (STACKADDBASE N) 0)))
(PUTPROPS STACKPUTBASE DMACRO ((N V) (\\PUTBASE (STACKADDBASE N) 0 V)))
(PUTPROPS STACKPUTBASEPTR DMACRO ((N V) (\\PUTBASEPTR (STACKADDBASE N) 0 V)))
(PUTPROPS \\MISCAPPLY* MACRO ((FN ARG1 ARG2) (UNINTERRUPTABLY (|replace| (IFPAGE MISCSTACKFN) |of| 
|\\InterfacePage| |with| FN) (|replace| (IFPAGE MISCSTACKARG1) |of| |\\InterfacePage| |with| ARG1) (
|replace| (IFPAGE MISCSTACKARG2) |of| |\\InterfacePage| |with| ARG2) (\\CONTEXTSWITCH |\\MiscFXP|) (
|fetch| (IFPAGE MISCSTACKRESULT) |of| |\\InterfacePage|))))
(BLOCKRECORD STACKP ((STACKP0 WORD) (EDFXP WORD)) (BLOCKRECORD STACKP ((STACKPOINTER FULLXPOINTER))) (
TYPE? (STACKP DATUM)))
(RPAQQ STACKTYPES (\\STK.GUARD \\STK.FX \\STK.BF \\STK.NOTFLAG \\STK.FSB \\STK.FLAGS.SHIFT (
\\STK.FSB.WORD (LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (\\STK.GUARD.WORD (LLSH \\STK.GUARD 
\\STK.FLAGS.SHIFT)) (\\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT))))
(RPAQQ \\STK.GUARD 7)
(RPAQQ \\STK.FX 6)
(RPAQQ \\STK.BF 4)
(RPAQQ \\STK.NOTFLAG 0)
(RPAQQ \\STK.FSB 5)
(RPAQQ \\STK.FLAGS.SHIFT 13)
(RPAQ \\STK.FSB.WORD (LLSH \\STK.FSB \\STK.FLAGS.SHIFT))
(RPAQ \\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT))
(RPAQ \\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT))
(CONSTANTS \\STK.GUARD \\STK.FX \\STK.BF \\STK.NOTFLAG \\STK.FSB \\STK.FLAGS.SHIFT (\\STK.FSB.WORD (
LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (\\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT)) (
\\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT)))
(RPAQQ |\\StackAreaSize| 768)
(RPAQ |\\InitStackSize| (ITIMES |\\StackAreaSize| 12))
(CONSTANTS |\\StackAreaSize| (|\\InitStackSize| (ITIMES |\\StackAreaSize| 12)))
(RPAQQ \\MAXSAFEUSECOUNT 200)
(CONSTANTS \\MAXSAFEUSECOUNT)
(BLOCKRECORD NAMETABLESLOT ((VARTYPE BYTE) (VAROFFSET BYTE)))
(BLOCKRECORD FVARSLOT ((BINDLO WORD) (BINDHI WORD)) (ACCESSFNS FVARSLOT ((LOOKEDUP (EVENP (|fetch| 
BINDLO |of| DATUM))) (BINDINGPTR (\\VAG2 (|fetch| BINDHI |of| DATUM) (|fetch| BINDLO |of| DATUM)) (
PROGN (|replace| BINDLO |of| DATUM |with| (\\LOLOC NEWVALUE)) (|replace| BINDHI |of| DATUM |with| (
\\HILOC NEWVALUE)))))))
(BLOCKRECORD PVARSLOT ((PVHI BITS 4) (PVVALUE XPOINTER)) (ACCESSFNS PVARSLOT ((BOUND (EQ (|fetch| (
PVARSLOT PVHI) |of| DATUM) 0) (|if| (NULL NEWVALUE) |then| (|replace| (PVARSLOT PVHI) |of| DATUM 
|with| 255) |else| (ERROR "Illegal replace" NEWVALUE))))))
(BLOCKRECORD STKTEMPSLOT ((STKTMPHI BITS 4) (VALUE XPOINTER)) (ACCESSFNS STKTEMPSLOT ((BINDINGPTRP (
NEQ (|fetch| STKTMPHI |of| DATUM) 0)))))
(BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES 
WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* \; 
"Value stored in high half is one's complement of number of values bound") (LOGXOR (|fetch| 
BINDNEGVALUES |of| DATUM) 65535))))))
(RPAQQ \\NT.IVAR 0)
(RPAQQ \\NT.PVAR 128)
(RPAQQ \\NT.FVAR 192)
(CONSTANTS \\NT.IVAR \\NT.PVAR \\NT.FVAR)
(PUTPROP (QUOTE LLSTK) (QUOTE IMPORTDATE) (IDATE " 6-Jan-1993 18:07:37"))

(PUTPROPS WORDCONTENTS BYTEMACRO ((PTR) (\\GETBASE PTR 0)))
(PUTPROPS SETWORDCONTENTS BYTEMACRO ((PTR N) (\\PUTBASE PTR 0 N)))
(PUTPROPS WORDOFFSET BYTEMACRO ((PTR N) (\\ADDBASE PTR N)))
(PUTPROPS \\RELEASECPAGE MACRO ((STREAM) (PROGN (* \; "Must be under an UNINTERRUPTABLY !") (COND ((
|fetch| CBUFDIRTY |of| STREAM) (\\SETIODIRTY STREAM (|fetch| CPAGE |of| STREAM)) (|replace| CBUFDIRTY 
|of| STREAM |with| NIL))) (|replace| CBUFSIZE |of| STREAM |with| 0) (|replace| CBUFPTR |of| STREAM 
|with| NIL))))
(PUTPROP (QUOTE PMAP) (QUOTE IMPORTDATE) (IDATE " 3-Feb-2002 14:11:02"))

(PUTPROPS ADDREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\\ADDREF PTR))))
(PUTPROPS \\ADDREF DMACRO ((X) ((OPCODES GCREF 0) X)))
(PUTPROPS DELETEREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\\DELREF PTR))))
(PUTPROPS \\DELREF DMACRO ((X) ((OPCODES GCREF 1) X)))
(PUTPROPS SCANREF MACRO (= . \\STKREF))
(PUTPROPS \\STKREF DMACRO ((X) ((OPCODES GCREF 2) X)))
(PUTPROPS UNSCANREF MACRO ((PTR) (\\HTFIND PTR 3)))
(PUTPROPS CREATEREF MACRO (= . \\CREATEREF))
(PUTPROPS \\CREATEREF MACRO (OPENLAMBDA (PTR) (PROG1 (\\DELREF PTR) (.INCREMENT.ALLOCATION.COUNT. 1)))
)
(PUTPROPS .INCREMENT.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \\RECLAIM.COUNTDOWN)
) (AND \\RECLAIM.COUNTDOWN (COND ((IGREATERP \\RECLAIM.COUNTDOWN N) (SETQ \\RECLAIM.COUNTDOWN (
IDIFFERENCE \\RECLAIM.COUNTDOWN N))) (T (SETQ \\RECLAIM.COUNTDOWN) (\\DORECLAIM))))))
(PUTPROPS .CHECK.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \\RECLAIM.COUNTDOWN)) (
AND \\RECLAIM.COUNTDOWN (COND ((NOT (IGREATERP \\RECLAIM.COUNTDOWN N)) (SETQ \\RECLAIM.COUNTDOWN) (
\\DORECLAIM))))))
(PUTPROPS \\GCDISABLED MACRO (NIL (PROGN (DECLARE (GLOBALVARS \\GCDISABLED)) \\GCDISABLED)))
(BLOCKRECORD HTOVERFLOW ((CASE BITS 4) (PTR XPOINTER)) (ACCESSFNS HTOVERFLOW ((CLEAR NIL (\\PUTBASEPTR
 DATUM 0 NIL)))))
(BLOCKRECORD GC ((CNT BITS 15) (STKBIT FLAG) (HIBITS BITS 15) (LINKP FLAG) (NXTPTR FIXP)) (BLOCKRECORD
 GC ((STKCNT WORD))) (ACCESSFNS GC ((EMPTY (EQ 0 (\\GETBASEFIXP DATUM 0)) (\\PUTBASEFIXP DATUM 0 0)) (
CONTENTS (\\GETBASEFIXP DATUM 0) (\\PUTBASEFIXP DATUM 0 NEWVALUE)) (LINKPTR (LOGAND (\\GETBASEFIXP 
DATUM 0) -2) (\\PUTBASEFIXP DATUM 0 (LOGOR NEWVALUE 1))))))
(BLOCKRECORD HTCOLL ((* |;;| 
"An entry in the GC collision table.  NEXTFREE is initialized to 2 by INITGC, as part of the MAKEINIT."
) (FREEPTR FIXP) (* \; "The GC table entry") (NEXTFREE FIXP) (* \; 
"If the entry is in use, points to the next entry in this collision chain.  If not, offset (in 1/2-entries) of the next free one on the chain."
)))
(PUTPROP (QUOTE LLGC) (QUOTE IMPORTDATE) (IDATE "19-Oct-1994 12:30:11"))

(PUTPROPS \\SYNCODE DMACRO (OPENLAMBDA (TABLE CHAR) (CHECK (|type?| CHARTABLE TABLE)) (* \; 
"0 is either NONE.TC, REAL.CCE, or OTHER.RC") (COND ((IGREATERP CHAR \\MAXTHINCHAR) (OR (AND (|fetch| 
(CHARTABLE NSCHARHASH) |of| TABLE) (GETHASH CHAR (|fetch| (CHARTABLE NSCHARHASH) |of| TABLE))) 0)) (T 
(\\GETBASEBYTE TABLE CHAR)))))
(PUTPROPS \\SETSYNCODE DMACRO (LAMBDA (TABLE CHAR CODE) (CHECK (|type?| CHARTABLE TABLE)) (* \; 
"0 is REAL.CCE, NONE.TC, OTHER.RC") (COND ((ILEQ CHAR \\MAXTHINCHAR) (\\PUTBASEBYTE TABLE CHAR CODE)) 
(T (\\SETFATSYNCODE TABLE CHAR CODE)))))
(DATATYPE CHARTABLE ((CHARSET0 256 BYTE) (NSCHARHASH FULLPOINTER)))
(RPAQQ CCECHOMODES (REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE))
(RPAQQ REAL.CCE 0)
(RPAQQ IGNORE.CCE 8)
(RPAQQ SIMULATE.CCE 16)
(RPAQQ INDICATE.CCE 24)
(CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)
(RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC 
CTRLV.TC))
(RPAQQ NONE.TC 0)
(RPAQQ EOL.TC 1)
(RPAQQ CHARDELETE.TC 2)
(RPAQQ WORDDELETE.TC 6)
(RPAQQ WORDSEPR.TC 7)
(RPAQQ LINEDELETE.TC 3)
(RPAQQ RETYPE.TC 4)
(RPAQQ CTRLV.TC 5)
(CONSTANTS NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC)
(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24)) (TERMCLASS (LOGAND DATUM 7))) (* \; 
"We assume that values are appropriately shifted") (CREATE (LOGOR CCECHO TERMCLASS)))
(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL (
CONTROLFLG FLAG) (ECHOFLG FLAG)) TERMSA _ (|create| CHARTABLE))
(PUTPROPS \\GETREADMACRODEF MACRO ((C TBL) (GETHASH C (|fetch| READMACRODEFS |of| TBL))))
(PUTPROPS \\GTREADTABLE MACRO (ARGS (COND ((LITATOM (CAR ARGS)) (SUBPAIR (QUOTE (X . FLG)) ARGS (QUOTE
 (SELECTQ X ((NIL T) (\\DTEST *READTABLE* (QUOTE READTABLEP))) (\\GTREADTABLE1 X . FLG))))) (T (QUOTE 
IGNOREMACRO)))))
(PUTPROPS \\GTREADTABLE1 DMACRO (ARGS (COND ((NULL (CDR ARGS)) (LIST (QUOTE \\DTEST) (CAR ARGS) (QUOTE
 (QUOTE READTABLEP)))) (T (QUOTE IGNOREMACRO)))))
(RPAQQ MACROBIT 8)
(RPAQQ BREAKBIT 16)
(RPAQQ STOPATOMBIT 32)
(RPAQQ ESCAPEBIT 64)
(RPAQQ INNERESCAPEBIT 4)
(CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
(RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR 
MACROBIT 2))))
(RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
(RPAQ WAKEUPMASK (LOGOR MACROBIT 2))
(CONSTANTS (CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2)))
(RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR 
MACROBIT 0)) (ALONE.RMC (LOGOR MACROBIT 1))))
(RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
(RPAQ FIRST.RMC (LOGOR MACROBIT 0))
(RPAQ ALONE.RMC (LOGOR MACROBIT 1))
(CONSTANTS (ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) (
ALONE.RMC (LOGOR MACROBIT 1)))
(RPAQQ READCLASSES ((OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR 
ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (
LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT 
BREAKBIT 3)) (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR 
ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC 
(LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))
(RPAQQ OTHER.RC 0)
(RPAQ SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0))
(RPAQ BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))
(RPAQ STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))
(RPAQ LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))
(RPAQ RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))
(RPAQ LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))
(RPAQ RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))
(RPAQ ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6))
(RPAQ MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7))
(RPAQ PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))
(CONSTANTS (OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT 
STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (LEFTPAREN.RC (
LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (
LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT
 BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT 
INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)))
(RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0))))
(RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2))
(RPAQ NONIMMEDIATE.RMW (LOGOR MACROBIT 0))
(CONSTANTS (IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0)))
(RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT) (NOESC.RME 0)))
(RPAQ ESC.RME ESCAPEBIT)
(RPAQQ NOESC.RME 0)
(CONSTANTS (ESC.RME ESCAPEBIT) (NOESC.RME 0))
(ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT)) (ESCQUOTE (BITTEST DATUM ESCAPEBIT)) (STOPATOM 
(BITTEST DATUM STOPATOMBIT)) (INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT))) (
MACROCONTEXT (LOGAND DATUM CONTEXTMASK)) (MACROP (BITTEST DATUM MACROBIT)) (WAKEUP (LOGAND DATUM 
WAKEUPMASK)) (BREAK (BITTEST DATUM BREAKBIT))))
(RECORD READMACRODEF (MACROTYPE . MACROFN))
(DATATYPE READTABLEP ((READSA POINTER) (* \; "A CHARTABLE defining syntax of each char") (
READMACRODEFS POINTER) (* \; "A hash table associating macro chars with macro definitions") (
READMACROFLG FLAG) (* \; 
"True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)") (ESCAPEFLG 
FLAG) (* \; 
"True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)"
) (COMMONLISP FLAG) (* \; 
"True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules") (NUMBERBASE 
BITS 5) (* \; "Not used") (CASEINSENSITIVE FLAG) (* \; 
"If true, unescaped lowercase chars are converted to uppercase in symbols") (COMMONNUMSYNTAX FLAG) (* 
\; 
"True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers"
) (USESILPACKAGE FLAG) (* \; "If true, IL:READ ignores *PACKAGE* and reads in the IL package") (NIL 5 
FLAG) (DISPATCHMACRODEFS POINTER) (* \; 
"An a-list of dispatching macro char and its dispatch definitions") (HASHMACROCHAR BYTE) (* \; 
"The character code used in this read table for the # dispatch macro") (ESCAPECHAR BYTE) (* \; 
"The character code used in this read table for single escape") (MULTESCAPECHAR BYTE) (* \; 
"The character code used in this read table for multiple escape") (PACKAGECHAR BYTE) (* \; 
"The character code used in this read table for package delimiter") (READTBLNAME POINTER) (* \; 
"The canonical 'name' of this read table")) READSA _ (|create| CHARTABLE))
(PUTPROP (QUOTE ATBL) (QUOTE IMPORTDATE) (IDATE "20-Apr-2018 17:35:56"))

(DATATYPE STREAM ((* |;;| 
"First 8 words are fixed for BIN, BOUT opcodes.  Used to require length of whole datatype be multiple of 4, but Dolphin dead now."
) (COFFSET WORD) (* \; "Offset in CPPTR of next bin or bout") (CBUFSIZE WORD) (* \; 
"Offset past last byte in that buffer") (PEEKEDCHARP FLAG) (* \; 
"if true, PEEKEDCHAR contains value of recent call to unread-char") (ACCESSBITS BITS 3) (* \; 
"What kind of access file is open for (read, write, append)") (CBUFPTR POINTER) (* \; 
"Pointer to current buffer") (BYTESIZE BYTE) (* \; "Byte size of stream, always 8 for now") (CHARSET 
BYTE) (* \; 
"the current character set for this stream.  If 255, stream is not runcoded, so read-char consumes two bytes every time"
) (PEEKEDCHAR WORD) (* \; "value of unread-char call") (CHARPOSITION WORD) (* \; 
"Used by POSITION etc.") (CBUFMAXSIZE WORD) (* \; 
"on output, the size of the physical buffer--can't extend beyond this") (* |;;| 
"-------- Above fields (8 words) potentially known to microcode.  --------") (NONDEFAULTDATEFLG FLAG) 
(REVALIDATEFLG FLAG) (MULTIBUFFERHINT FLAG) (* \; 
"True if stream likes to read and write more than one buffer at a time") (USERCLOSEABLE FLAG) (* \; 
"Can be closed by CLOSEF;  NIL for terminal, dribble...") (FULLFILENAME POINTER) (* \; 
"Name by which file is known to user") (BINABLE FLAG) (* \; "BIN punts unless this bit on") (BOUTABLE 
FLAG) (* \; "BOUT punts unless this bit on") (EXTENDABLE FLAG) (* \; 
"BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512") (CBUFDIRTY FLAG) (* \; 
"true if BOUT has sullied the current buffer") (DEVICE POINTER) (* \; "FDEV of this guy") (USERVISIBLE
 FLAG) (* \; "Listed by OPENP;  NIL for terminal, dribble ...") (EOLCONVENTION BITS 2) (* \; 
"End-of-line convention") (NOTXCCS FLAG) (* \; "True if the character encoding format is not XCCS.") (
VALIDATION POINTER) (* \; 
"A number somehow identifying file, used to determine if file has changed in our absence") (CPAGE 
POINTER) (* \; "CPAGE,,COFFSET constitutes current file pointer for most randaccess streams") (EPAGE 
POINTER) (EOFFSET WORD) (* \; "Page, byte offset of eof") (LINELENGTH WORD) (* \; 
"LINELENGTH of stream, or -1 for no line length") (* |;;| 
"----Following are device-specific fields----") (* |;;| 
"Available for device-specific uses, NOT for application use.") (F1 POINTER) (F2 POINTER) (F3 POINTER)
 (F4 POINTER) (F5 POINTER) (FW6 WORD) (FW7 WORD) (FW8 WORD) (FW9 WORD) (F10 POINTER) (* |;;| 
"----Following only filled in for open streams----") (STRMBINFN POINTER) (* \; 
"Either the BIN fn from the FDEV, or a trap") (STRMBOUTFN POINTER) (* \; 
"Either the BIN fn from the FDEV, or a trap") (OUTCHARFN POINTER) (* \; 
"Called by \\OUTCHAR, the normal character printer.") (ENDOFSTREAMOP POINTER) (* \; 
"Called if EOF and we try to read.") (OTHERPROPS POINTER) (* \; "PROP LIST for holding other info.") (
IMAGEOPS POINTER) (* \; "Image operations vector") (IMAGEDATA POINTER) (* \; 
"Image instance variables--format depends on IMAGEOPS value") (BUFFS POINTER) (* \; 
"Buffer chain for pmapped streams") (MAXBUFFERS WORD) (* \; 
"Max # of buffers the system will allocate.") (LASTCCODE WORD) (* \; 
"After READ, RATOM, etc, the charcode that will be returned (as a character) by LASTC.  If there is none, this field is 65535."
) (EXTRASTREAMOP POINTER) (* \; "For use of applications programs, not devices")) (BLOCKRECORD STREAM 
((NIL 2 WORD) (UCODEFLAGS1 BITS 1) (* |;;| "respecification of access bits:") (RANDOMWRITEABLE FLAG) (
* \; "File open for output (access = OUTPUT or BOTH)") (APPENDABLE FLAG) (* \; 
"File open for append (OUTPUT or APPEND or BOTH)") (READABLE FLAG) (* \; 
"File open for read (READ or BOTH)") (NIL POINTER))) (BLOCKRECORD STREAM ((NIL 4 WORD) (NIL BITS 14) (
* |;;| "JIS character encoding format specific, overrides CHARSET field.") (IN.KANJIIN FLAG) (* \; 
"True if input stream is in Kanji-in mode.") (OUT.KANJIIN FLAG) (* \; 
"True if output stream is in Kanji-in mode."))) (ACCESSFNS STREAM ((ACCESS \\GETACCESS \\SETACCESS) (
FULLNAME (OR (|fetch| (STREAM FULLFILENAME) |of| DATUM) DATUM)) (NAMEDP (AND (|fetch| (STREAM 
FULLFILENAME) |of| DATUM) T)))) (ACCESSFNS STREAM (EXTERNALFORMAT (LISTGET (|ffetch| (STREAM 
OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)) (LET ((PROPS (|ffetch| (STREAM OTHERPROPS) |of| DATUM)
)) (|freplace| (STREAM NOTXCCS) |of| DATUM |with| T) (COND (PROPS (LISTPUT PROPS (QUOTE EXTERNALFORMAT
) NEWVALUE)) (T (|freplace| (STREAM OTHERPROPS) |of| DATUM |with| (LIST (QUOTE EXTERNALFORMAT) 
NEWVALUE)))) (|freplace| (STREAM OUTCHARFN) |of| DATUM |with| (|ffetch| (EXTERNALFORMAT FILEOUTCHARFN)
 |of| NEWVALUE)) (AND (|ffetch| (EXTERNALFORMAT EOLVALID) |of| NEWVALUE) (|freplace| (STREAM 
EOLCONVENTION) |of| DATUM |with| (|ffetch| (EXTERNALFORMAT EOL) |of| NEWVALUE)))))) (ACCESSFNS STREAM 
(EXTERNALFORMAT.NAME (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT.NAME)) (
LET ((PROPS (|ffetch| (STREAM OTHERPROPS) |of| DATUM)) (NAME (COND ((LITATOM NEWVALUE) NEWVALUE) (T (
MKATOM NEWVALUE))))) (|freplace| (STREAM NOTXCCS) |of| DATUM |with| T) (COND (PROPS (LISTPUT PROPS (
QUOTE EXTERNALFORMAT.NAME) NAME)) (T (|freplace| (STREAM OTHERPROPS) |of| DATUM |with| (LIST (QUOTE 
EXTERNALFORMAT.NAME) NAME))))))) (ACCESSFNS STREAM (INCCODEFN (LET ((XFMT (LISTGET (|ffetch| (STREAM 
OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch| (
EXTERNALFORMAT INCCODEFN) |of| XFMT))))) (ACCESSFNS STREAM (PEEKCCODEFN (LET ((XFMT (LISTGET (|ffetch|
 (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch|
 (EXTERNALFORMAT PEEKCCODEFN) |of| XFMT))))) (ACCESSFNS STREAM (BACKCHARFN (LET ((XFMT (LISTGET (
|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) 
(|fetch| (EXTERNALFORMAT BACKCHARFN) |of| XFMT))))) (ACCESSFNS STREAM (FILEOUTCHARFN (|ffetch| (STREAM
 OUTCHARFN) |of| DATUM))) (SYNONYM CBUFPTR (CPPTR)) USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ 
|NoBits| CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE (
GLOBALVARS \\STREAM.DEFAULT.MAXBUFFERS)) \\STREAM.DEFAULT.MAXBUFFERS) CHARPOSITION _ 0 LINELENGTH _ (
LET NIL (DECLARE (GLOBALVARS FILELINELENGTH)) FILELINELENGTH) OUTCHARFN _ (FUNCTION \\FILEOUTCHARFN) 
ENDOFSTREAMOP _ (FUNCTION \\EOSERROR) IMAGEOPS _ \\NOIMAGEOPS EOLCONVENTION _ (SELECTQ (SYSTEMTYPE) (D
 CR.EOLC) (VAX LF.EOLC) (JERICHO CRLF.EOLC) CR.EOLC) STRMBINFN _ (FUNCTION \\STREAM.NOT.OPEN) 
STRMBOUTFN _ (FUNCTION \\STREAM.NOT.OPEN) LASTCCODE _ 65535 NOTXCCS _ NIL)
(PUTPROPS STREAMOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) (
QUOTE QUOTE)) (LIST (QUOTE |fetch|) (CADAR ARGS) (QUOTE |of|) (CADR ARGS))) (T (HELP 
"STREAMOP - OPNAME not quoted:" ARGS))) (CDDR ARGS)))))
(RPAQQ |AppendBit| 2)
(RPAQQ |NoBits| 0)
(RPAQQ |ReadBit| 1)
(RPAQQ |WriteBit| 4)
(RPAQ |OutputBits| (LOGOR |AppendBit| |WriteBit|))
(RPAQ |BothBits| (LOGOR |ReadBit| |OutputBits|))
(RPAQQ \\NORUNCODE 255)
(CONSTANTS |AppendBit| |NoBits| |ReadBit| |WriteBit| (|OutputBits| (LOGOR |AppendBit| |WriteBit|)) (
|BothBits| (LOGOR |ReadBit| |OutputBits|)) \\NORUNCODE)
(PUTPROPS |TestMasked| MACRO ((BITS MASK) (NEQ (LOGAND BITS MASK) 0)))
(PUTPROPS APPENDABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |AppendBit|)))
(PUTPROPS APPENDONLY MACRO ((STREAM) (EQ (|fetch| ACCESSBITS |of| STREAM) |AppendBit|)))
(PUTPROPS DIRTYABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) (CONSTANT (LOGOR 
|AppendBit| |WriteBit|)))))
(PUTPROPS OPENED MACRO ((STREAM) (NEQ (|fetch| ACCESSBITS |of| STREAM) |NoBits|)))
(PUTPROPS OVERWRITEABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |WriteBit|)))
(PUTPROPS READABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |ReadBit|)))
(PUTPROPS READONLY MACRO ((STREAM) (EQ (|fetch| ACCESSBITS |of| STREAM) |ReadBit|)))
(PUTPROPS WRITEABLE MACRO ((STREAM) (OR (OVERWRITEABLE STREAM) (AND (APPENDABLE STREAM) (\\EOFP STREAM
)))))
(PUTPROPS \\RUNCODED MACRO (OPENLAMBDA (STREAM) (* |;;| 
"returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented"
) (* \; "note that neq is ok since charsets are known to be SMALLP's") (NEQ (|fetch| CHARSET |of| 
STREAM) \\NORUNCODE)))
(RPAQQ EOLCONVENTIONS ((CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2)))
(RPAQQ CR.EOLC 0)
(RPAQQ LF.EOLC 1)
(RPAQQ CRLF.EOLC 2)
(CONSTANTS (CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2))
(PUTPROPS FDEVOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS))
) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (|fetch| (FDEV (
\\\, (CADR OPNAME))) |of| (\\\, METHOD-DEVICE)) (\\\,@ TAIL)))) (T (ERROR "OPNAME not quoted: " OPNAME
))))))
(PUTPROPS \\RECOGNIZE-HACK DMACRO (ARGS (LET ((NAME (CAR ARGS)) (RECOG (CADR ARGS)) (DEVICE (CADDR 
ARGS))) (BQUOTE (|if| (|type?| STREAM (\\\, NAME)) |then| (\\\, NAME) |else| (FDEVOP (QUOTE 
GETFILENAME) (\\\, DEVICE) (\\\, NAME) (\\\, RECOG) (\\\, DEVICE)))))))
(DATATYPE FDEV ((RESETABLE FLAG) (* \; "Obsolete") (RANDOMACCESSP FLAG) (NODIRECTORIES FLAG) (
PAGEMAPPED FLAG) (* \; "True if i/o handled by pmap routines") (FDBINABLE FLAG) (* \; 
"Copied as a microcode flag for INPUT streams formed on this device") (FDBOUTABLE FLAG) (FDEXTENDABLE 
FLAG) (BUFFERED FLAG) (* \; 
"True implies that the device supports the BIN & BOUT uCode conventions, and implements the GETNEXTBUFFER method"
) (DEVICENAME POINTER) (* \; "Identifying name somehow") (REMOTEP FLAG) (* \; 
"true if device not local to machine") (SUBDIRECTORIES FLAG) (* \; 
"true if device has real subdirectories") (INPUT-INDIRECTED FLAG) (* \; 
"True for devices that indirect their input stream.  Method INPUTSTREAM fetches it") (
OUTPUT-INDIRECTED FLAG) (* \; 
"True for devices that indirect their output stream.  Method OUTPUTSTREAM fetches it") (DEVICEINFO 
POINTER) (* \; "arbitrary device-specific info stored here") (OPENFILELST POINTER) (* \; 
"Default place to keep list of streams open on this device") (* |;;| 
"-----Rest of record consists of device \"methods\"-----") (* |;;| 
"-----Following fields required of all devices-----") (HOSTNAMEP POINTER) (* \; 
"(hostname {device}) => T if hostname is valid.  If device is given, return a FDEV for this {new} host, or T to use existing device"
) (EVENTFN POINTER) (* \; "(device event), called before/after logout, sysout, makesys") (* |;;| 
"-----Following fields required of all named devices, e.g., ones that open files-----") (
DIRECTORYNAMEP POINTER) (* \; "(host/dir) => true if directory exists on host") (OPENFILE POINTER) (* 
\; "(name access recog otherinfo device) => new stream open on this device, or NIL if name not found")
 (CLOSEFILE POINTER) (* \; "(stream) => closes stream, returns it") (REOPENFILE POINTER) (* \; 
"(name access recog otherinfo device stream) like openfile, but called after logout to revalidate file, so optionally uses info in old stream to keep this opening like the previous"
) (GETFILENAME POINTER) (* \; "(name recog device) => full file name") (DELETEFILE POINTER) (* \; 
"(name) => deletes file so named, returning name, or NIL on failure.  RECOG=OLDEST") (GENERATEFILES 
POINTER) (* \; 
"(device pattern) => generator object for files matching pattern.  Car of object is generator function, cdr is arbitrary state.  Generator fn returns next file, or NIL when finished"
) (RENAMEFILE POINTER) (* \; 
"(olddevice oldfile newdevice newfile) to rename file on this (olddevice) to a potentially different device."
) (OPENP POINTER) (* \; 
"(name access dev) => stream if name is open for access, or all open streams if name = NIL") (
REGISTERFILE POINTER) (* \; "(stream dev) => registers stream on its device") (UNREGISTERFILE POINTER)
 (* \; "(stream dev) => unregisters a stream from its device") (FREEPAGECOUNT POINTER) (* \; 
"(host/dir dev) => # of free pages on host/dir") (MAKEDIRECTORY POINTER) (* \; "(host/dir dev)") (
CHECKFILENAME POINTER) (* \; "(name dev) => name if it is well-formed file name for dev") (HOSTALIVEP 
POINTER) (* \; 
"(host dev) => true if host is alive, i.e., responsive;  only defined if REMOTEP is true") (
BREAKCONNECTION POINTER) (* \; "(host fastp dev) => closes connections to host") (* |;;| 
"-----The following are required methods for operating on open streams-----") (BIN POINTER) (* \; 
"(stream) => next byte of input") (BOUT POINTER) (* \; "(stream byte) output byte to stream") (PEEKBIN
 POINTER) (* \; "(stream) => next byte without advancing position in stream") (READCHAR POINTER) (* \;
 "(stream) => next input char") (WRITECHAR POINTER) (* \; "(stream char) => writes char to stream") (
PEEKCHAR POINTER) (UNREADCHAR POINTER) (READP POINTER) (* \; 
"(stream flag) => T if there is input available from stream right now") (EOFP POINTER) (* \; 
"(stream) => T if BIN would signal eof.") (BLOCKIN POINTER) (* \; "(stream buffer byteoffset nbytes)")
 (BLOCKOUT POINTER) (* \; "(stream buffer byteoffset nbytes)") (FORCEOUTPUT POINTER) (* \; 
"(stream waitForFinish) flushes out to device anything that is buffered awaiting transmission") (
GETFILEINFO POINTER) (* \; 
"(stream/name attribute device) => value of attribute for open stream or name of closed file") (
SETFILEINFO POINTER) (* \; 
"(stream/name attribute newvalue device) sets attribute of open stream or closed file of given name") 
(CHARSETFN POINTER) (* \; 
"(stream charset) => access function for the charset slot, for benefit of indirect streams.  See IMCHARSET for changing it on a file."
) (INPUTSTREAM POINTER) (* \; "(stream) => indirected input stream") (OUTPUTSTREAM POINTER) (* \; 
"(stream) => indirected output stream") (* |;;| 
"-----Following are required of random-access streams-----") (GETFILEPTR POINTER) (GETEOFPTR POINTER) 
(SETFILEPTR POINTER) (BACKFILEPTR POINTER) (* \; 
"(stream) backs up `fileptr' by one.  Stream is only required to be able to do this once, i.e.  one-character buffer suffices"
) (SETEOFPTR POINTER) (* \; "(stream length) => truncates or lengthens stream to indicated length") (
LASTC POINTER) (* \; "Should be possible only if RANDOMACCESSP") (* |;;| 
"-----Following used for buffered streams-----") (GETNEXTBUFFER POINTER) (* \; 
"(stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next.  whatfor is READ or WRITE.  Can cause EOF error unless noerrorflg"
) (RELEASEBUFFER POINTER) (* \; "(stream) => Does whatever appropriate when CBUFPTR is released") (* 
|;;| "-----Following used for pagemapped streams-----") (READPAGES POINTER) (* \; 
"(stream firstpage# buflist) => # of bytes read, starting at firstpage#, reading into buflist, a list of buffers or a single buffer (the usual case)"
) (WRITEPAGES POINTER) (* \; 
"(stream firstpage# buflist) writes from buflist to stream starting at firstpage# of stream") (
TRUNCATEFILE POINTER) (* \; 
"(stream page offset) make stream's eof be at page,offset, discarding anything after it") (* |;;| 
"-----For window system, argh-----") (WINDOWOPS POINTER) (* \; "window system operations") (WINDOWDATA
 POINTER) (* \; "data for window systems") (* |;;| 
"-----For any stream (here to not recompile everything)-----") (READCHARCODE POINTER) (* \; 
"Read a character code from the stream (cf BIN for bytes).")) DIRECTORYNAMEP _ (FUNCTION NILL) 
HOSTNAMEP _ (FUNCTION NILL) READP _ (FUNCTION \\GENERIC.READP) SETFILEPTR _ (FUNCTION 
\\IS.NOT.RANDACCESSP) GETFILEPTR _ (FUNCTION \\ILLEGAL.DEVICEOP) GETEOFPTR _ (FUNCTION 
\\IS.NOT.RANDACCESSP) EOFP _ (FUNCTION \\ILLEGAL.DEVICEOP) BLOCKIN _ (FUNCTION \\GENERIC.BINS) 
BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS) RENAMEFILE _ (FUNCTION \\GENERIC.RENAMEFILE) FORCEOUTPUT _ (
FUNCTION NILL) REGISTERFILE _ (FUNCTION NILL) OPENP _ (FUNCTION NILL) UNREGISTERFILE _ (FUNCTION NILL)
 READCHAR _ (FUNCTION \\GENERIC.READCHAR) WRITECHAR _ (FUNCTION \\GENERIC.WRITECHAR) PEEKCHAR _ (
FUNCTION \\GENERIC.PEEKCHAR) UNREADCHAR _ (FUNCTION \\GENERIC.UNREADCHAR) CHARSETFN _ (FUNCTION 
\\GENERIC.CHARSET) BREAKCONNECTION _ (FUNCTION NILL) READCHARCODE _ (FUNCTION \\GENERIC.READCCODE))
(RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE))
(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (* \; 
"If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream.") (EOL 
BITS 2) (NIL BITS 1) (INCCODEFN POINTER) (* \; "Called with two arguments -- STREAM and COUNTP") (
PEEKCCODEFN POINTER) (* \; "Called with three arguments -- STREAM, NOERROR and COUNTP") (BACKCHARFN 
POINTER) (* \; "Called with two arguments -- STREAM and COUNTP") (FILEOUTCHARFN POINTER) (* \; 
"Called with two arguments -- STREAM and CHARCODE")) EOLVALID _ NIL)
(PUTPROPS \\OUTCHAR DMACRO (OPENLAMBDA (STREAM CHARCODE) (STREAMOP (QUOTE OUTCHARFN) STREAM STREAM 
CHARCODE)))
(PUTPROPS \\DEVICE-OPEN-STREAMS MACRO (ARGS (LET ((DEVICE (CAR ARGS))) (BQUOTE (FDEVOP (QUOTE OPENP) (
\\\, DEVICE) NIL NIL (\\\, DEVICE))))))
(PUTPROPS \\CONVERT-PATHNAME DMACRO (OPENLAMBDA (PATHNAME?) (* |;;| 
"Coerce pathnames to Interlisp strings, for the benefit of antediluvian Interlisp-D file fns") (
CL:TYPECASE PATHNAME? (PATHNAME (INTERLISP-NAMESTRING PATHNAME?)) (T PATHNAME?))))
(DEFOPTIMIZER ACCESS-CHARSET (STREAM &OPTIONAL NEWVALUE) (BQUOTE ((OPENLAMBDA (STRM) (FDEVOP (QUOTE 
CHARSETFN) (|fetch| (STREAM DEVICE) |of| STRM) STRM (\\\, NEWVALUE))) (\\\, STREAM))))
(PUTPROPS \\DECFILEPTR MACRO ((STREAM X) (\\INCFILEPTR STREAM (IMINUS X))))
(PUTPROPS \\GETFILEPTR MACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE GETFILEPTR) (|fetch| DEVICE |of| STRM) 
STRM)))
(PUTPROPS \\SIGNEDWIN MACRO ((STREAM) (SIGNED (\\WIN STREAM) BITSPERWORD)))
(PUTPROPS \\SIGNEDWOUT MACRO ((STREAM N) (\\WOUT STREAM (UNSIGNED N BITSPERWORD))))
(PUTPROPS \\WIN MACRO (OPENLAMBDA (STREAM) (|create| WORD HIBYTE _ (\\BIN STREAM) LOBYTE _ (\\BIN 
STREAM))))
(PUTPROPS \\WOUT MACRO (OPENLAMBDA (STREAM W) (\\BOUT STREAM (|fetch| HIBYTE |of| W)) (\\BOUT STREAM (
|fetch| LOBYTE |of| W))))
(PUTPROPS \\BINS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKIN) (|fetch| (STREAM
 DEVICE) |of| STRM) STRM BASE OFF NBYTES)))
(PUTPROPS \\BOUTS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKOUT) (|fetch| (
STREAM DEVICE) |of| STRM) STRM BASE OFF NBYTES)))
(PUTPROPS \\EOFP BYTEMACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE EOFP) (|fetch| (STREAM DEVICE) |of| STRM)
 STRM)))
(PUTPROPS SIZE.FROM.LENGTH MACRO (LAMBDA (LEN) (DECLARE (LOCALVARS LEN)) (AND LEN (FOLDHI LEN 
BYTESPERPAGE))))
(RPAQQ |BitsPerByte| 8)
(RPAQ |ByteOffsetSize| (SELECTQ (SYSTEMTYPE) (VAX 10) 9))
(RPAQQ |WordsPerPage| 256)
(CONSTANTS |BitsPerByte| (|ByteOffsetSize| (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) |WordsPerPage|)
(RPAQ \\MAXFILEPTR (SUB1 (LLSH 1 30)))
(CONSTANTS (\\MAXFILEPTR (SUB1 (LLSH 1 30))))
(ACCESSFNS BYTEPTR ((PAGE (FOLDLO DATUM BYTESPERPAGE)) (OFFSET (MOD DATUM BYTESPERPAGE))) (TYPE? (AND 
(FIXP DATUM) (IGEQ DATUM 0) (ILEQ DATUM \\MAXFILEPTR))) (CREATE (IPLUS (UNFOLD PAGE BYTESPERPAGE) 
OFFSET)))
(PUTPROP (QUOTE FILEIO) (QUOTE IMPORTDATE) (IDATE "13-Aug-2020 11:43:08"))

(BLOCKRECORD FIXP ((HINUM WORD) (LONUM WORD)) (CREATE (CREATECELL \\FIXP)) (TYPE? (EQ (NTYPX DATUM) 
\\FIXP)))
(RPAQQ MAX.SMALL.INTEGER 65535)
(RPAQQ MAX.POS.HINUM 32767)
(CONSTANTS (MAX.SMALL.INTEGER 65535) (MAX.POS.HINUM 32767))
(PUTPROPS .UNBOX. MACRO (ARGS (LET ((ARG-FORM (CAR ARGS)) (HIGH-VAR (CADR ARGS)) (LOW-VAR (CADDR ARGS)
) (BIGNUM-FORM (CADDDR ARGS))) (BQUOTE (PROG NIL UBLP (SELECTC (NTYPX (\\\, ARG-FORM)) (\\FIXP (SETQ (
\\\, HIGH-VAR) (|ffetch| (FIXP HINUM) |of| (\\\, ARG-FORM))) (SETQ (\\\, LOW-VAR) (|ffetch| (FIXP 
LONUM) |of| (\\\, ARG-FORM)))) (\\SMALLP (COND ((ILEQ 0 (\\\, ARG-FORM)) (SETQ (\\\, HIGH-VAR) 0) (
SETQ (\\\, LOW-VAR) (\\\, ARG-FORM))) (T (SETQ (\\\, HIGH-VAR) 65535) (SETQ (\\\, LOW-VAR) (\\LOLOC (
\\\, ARG-FORM)))))) (\\FLOATP (SETQ (\\\, ARG-FORM) (\\FIXP.FROM.FLOATP (\\\, ARG-FORM))) (GO UBLP)) (
COND ((TYPENAMEP (\\\, ARG-FORM) (QUOTE RATIO)) (SETQ (\\\, ARG-FORM) (IQUOTIENT (CL::RATIO-NUMERATOR 
(\\\, ARG-FORM)) (CL::RATIO-DENOMINATOR (\\\, ARG-FORM)))) (GO UBLP)) (\\\,@ (COND (BIGNUM-FORM (
BQUOTE (((CL:INTEGERP (\\\, ARG-FORM)) (\\\, BIGNUM-FORM))))) (T (BQUOTE (((CL:INTEGERP (\\\, ARG-FORM
)) (\\ILLEGAL.ARG (\\\, ARG-FORM)))))))) (T (CL::%NOT-NONCOMPLEX-NUMBER-ERROR (\\\, ARG-FORM))))))))))
(PUTPROPS .NEGATE. MACRO ((HY LY) (COND ((EQ 0 LY) (AND (NEQ HY 0) (SETQ HY (ADD1 (IDIFFERENCE 
MAX.SMALL.INTEGER HY))))) (T (SETQ HY (IDIFFERENCE MAX.SMALL.INTEGER HY)) (SETQ LY (ADD1 (IDIFFERENCE 
MAX.SMALL.INTEGER LY)))))))
(PUTPROPS .LLSH1. MACRO ((HI LO) (* \; "shift the pair left one, assuming no overflow") (SETQ HI (LLSH
 HI 1)) (SETQ LO (LLSH (COND ((IGREATERP LO MAX.POS.HINUM) (|add| HI 1) (LOGAND LO MAX.POS.HINUM)) (T 
LO)) 1))))
(PUTPROPS .LRSH1. MACRO ((HI LO) (SETQ LO (LRSH LO 1)) (COND ((NEQ (LOGAND HI 1) 0) (SETQ LO (IPLUS LO
 \\SIGNBIT)))) (SETQ HI (LRSH HI 1))))
(PUTPROPS .BOXIPLUS. MACRO (OPENLAMBDA (X Y) (PROG ((HX (\\GETBASE X 0)) (LX (\\GETBASE X 1)) HY LY) (
.UNBOX. Y HY LY) (SETQ HX (COND ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY)) (IDIFFERENCE HX (
ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY)))) (T (IPLUS HX HY)))) (* |Add| |high| |parts|) (\\PUTBASE X 1
 (COND ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY)) (* |Carry| |into| |high| |part.|) (SETQ HX (
COND ((EQ HX MAX.SMALL.INTEGER) 0) (T (ADD1 HX)))) (IDIFFERENCE LX (ADD1 (IDIFFERENCE 
MAX.SMALL.INTEGER LY)))) (T (IPLUS LX LY)))) (\\PUTBASE X 0 HX) (RETURN X))))
(PUTPROPS |PutUnboxed| DMACRO (= . \\PUTFIXP))
(PUTPROP (QUOTE LLARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 18:47:56"))

(PUTPROPS POLYEVAL DMACRO ((X COEFFS DEGREE) (* \; 
"execute the POLYEVAL opcode on the value X, the array COEFFS with degree DEGREE") (\\FLOATBOX ((
OPCODES UBFLOAT3 0) (\\FLOATUNBOX X) (|fetch| (ARRAYP BASE) |of| COEFFS) DEGREE))))
(BLOCKRECORD FLOATP ((SIGNBIT BITS 1) (EXPONENT BITS 8) (HIFRACTION BITS 7) (LOFRACTION BITS 16)) (
BLOCKRECORD FLOATP ((HIWORD WORD) (LOWORD WORD))) (BLOCKRECORD FLOATP ((NIL BITS 9) (LONGFRACTION BITS
 23))) (BLOCKRECORD FLOATP ((FLOATCONTENTS BITS 32))) (BLOCKRECORD FLOATP ((NIL BITS 1) (
HIWORDNOSIGNBIT BITS 15))) (CREATE (\\FLOATBOX (\\VAG2 (LOGOR (LLSH SIGNBIT (PLUS 7 8)) (LLSH EXPONENT
 7) HIFRACTION) LOFRACTION))) LOFRACTION _ 0 HIFRACTION _ 0 EXPONENT _ 0 SIGNBIT _ 0 (ACCESSFNS FLOATP
 ((EXP (LOGAND (LRSH (\\HILOC (\\FLOATUNBOX DATUM)) 7) 255)) (HIFRAC (LOGAND (\\HILOC (\\FLOATUNBOX 
DATUM)) 127)))))
(RPAQQ MAX.DIGITS.ACCURACY 9)
(CONSTANTS (MAX.DIGITS.ACCURACY 9))
(PUTPROPS \\CALLER.ARGS MACRO (X (LET ((ARGS (CAR X)) (FORMS (CDR X))) (BQUOTE (PROGN (\\SLOWRETURN) (
LET ((AL (\\MYALINK)) NEXT (\\\,@ (|for| VAR |in| ARGS |collect| (COND ((LISTP VAR) (LIST (CAR VAR) 0)
) (T VAR))))) (DECLARE (\\\,@ (|for| VAR |in| ARGS |when| (LISTP VAR) |collect| (BQUOTE (TYPE (\\\, (
SELECTQ (CADR VAR) ((FLOATING FLOATP) (CADR VAR)) (HELP))) (\\\, (CAR VAR))))))) (SETQ NEXT (|fetch| (
FX NEXTBLOCK) |of| AL)) (\\\,@ (|for| X |in| (REVERSE ARGS) |collect| (LET ((FORMS (BQUOTE (
\\.GETBASE32 \\STACKSPACE (SETQ NEXT (IDIFFERENCE NEXT WORDSPERCELL)))))) (COND ((LISTP X) (BQUOTE (
SETQ (\\\, (CAR X)) (\\FLOATBOX (\\\, FORMS))))) (T (BQUOTE (SETQ (\\\, X) (\\\, FORMS)))))))) (
\\MAKEFREEBLOCK NEXT (TIMES (\\\, (LENGTH ARGS)) WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| AL 
|with| NEXT) (PROGN (\\\,@ FORMS))))))))
(PUTPROP (QUOTE LLFLOAT) (QUOTE IMPORTDATE) (IDATE "16-May-1990 19:26:51"))

(DEFOPTIMIZER FONTPROP (&REST ARGS) (SELECTQ (AND (EQ (CAADR ARGS) (QUOTE QUOTE)) (CADADR ARGS)) (
ASCENT (LIST (QUOTE FONTASCENT) (CAR ARGS))) (DESCENT (LIST (QUOTE FONTDESCENT) (CAR ARGS))) (HEIGHT (
LIST (QUOTE FONTHEIGHT) (CAR ARGS))) (QUOTE IGNOREMACRO)))
(DATATYPE FONTCLASS ((PRETTYFONT# BYTE) DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))
(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) (FONTFAMILY POINTER) (FONTSIZE POINTER) (FONTFACE 
POINTER) (|\\SFAscent| WORD) (|\\SFDescent| WORD) (|\\SFHeight| WORD) (ROTATION WORD) (FBBOX 
SIGNEDWORD) (FBBOY SIGNEDWORD) (FBBDX SIGNEDWORD) (FBBDY SIGNEDWORD) (|\\SFLKerns| POINTER) (
|\\SFRWidths| POINTER) (FONTDEVICESPEC POINTER) (* \; 
"Holds the spec by which the font is known to the printing device, if coercion has been done") (
OTHERDEVICEFONTPROPS POINTER) (* \; "For individual devices to hang special information") (FONTSCALE 
POINTER) (\\SFFACECODE BITS 8) (FONTAVGCHARWIDTH WORD) (* \; 
"Set in FONTCREATE, used to fix up the linelength when DSPFONT is called") (FONTIMAGEWIDTHS POINTER) (
* \; 
"This is the image width, as opposed to the advanced width;  initial hack for accents, kerning.  Fields is referenced by FONTCREATE."
) (FONTCHARSETVECTOR POINTER) (* \; 
"A 256-pointer block, with one pointer per 'character set' --each group of 256 character codes.  Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset."
) (FONTEXTRAFIELD2 POINTER)) FONTCHARSETVECTOR _ (\\CREATEFONTCHARSETVECTOR))
(RECORD FONTFACE (WEIGHT SLOPE EXPANSION) (ACCESSFNS ((COLOR (CDDDR DATUM) (RPLACD (CDDR DATUM) 
NEWVALUE)) (BACKCOLOR (COND ((CDDDR DATUM) (CAR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) (
RPLACD (CDDR DATUM) (LIST NIL NIL)))) (RPLACA (CDDDR DATUM) NEWVALUE))) (FORECOLOR (COND ((CDDDR DATUM
) (CADR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) (RPLACD (CDDR DATUM) (LIST NIL NIL)))) (
RPLACA (CDR (CDDDR DATUM)) NEWVALUE))))) WEIGHT _ (QUOTE MEDIUM) SLOPE _ (QUOTE REGULAR) EXPANSION _ (
QUOTE REGULAR) (TYPE? LISTP))
(DATATYPE CHARSETINFO (WIDTHS (* \; 
"The advance-width of each character, an array indexed by charcode.  Usually the same as the imagewidth, but can differ for accents, kerns kerns.  This is what should be used for stringwidth calculations."
) OFFSETS (* \; "Offset of each character into the image bitmap;  X value of left edge") IMAGEWIDTHS (
* \; "imagewidths is not automagically allocated since it is not always needed") CHARSETBITMAP (* \; 
"Bitmap containing the character images, indexed by OFFSETS") YWIDTHS (CHARSETASCENT WORD) (* \; 
"Max ascent for all characters in this CHARSET") (CHARSETDESCENT WORD) (* \; 
"Max descent for all characters in this CHARSET") LEFTKERN) WIDTHS _ (\\CREATECSINFOELEMENT) OFFSETS _
 (\\CREATECSINFOELEMENT))
(PUTPROPS FONTASCENT MACRO ((FONTSPEC) (|ffetch| |\\SFAscent| |of| (\\GETFONTDESC FONTSPEC))))
(PUTPROPS FONTDESCENT MACRO ((FONTSPEC) (|ffetch| |\\SFDescent| |of| (\\GETFONTDESC FONTSPEC))))
(PUTPROPS FONTHEIGHT MACRO ((FONTSPEC) (|ffetch| |\\SFHeight| |of| (\\GETFONTDESC FONTSPEC))))
(PUTPROPS \\FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) (\\GETBASE OFFSETSBLOCK CHAR8CODE)))
(PUTPROPS \\FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET) (\\PUTBASE OFFSETSBLOCK CHAR8CODE 
OFFSET)))
(PUTPROPS \\FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) (\\GETBASE WIDTHSBLOCK CHAR8CODE)))
(PUTPROPS \\FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
(PUTPROPS \\FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE) (\\FGETWIDTH (|ffetch| (CHARSETINFO 
WIDTHS) |of| (\\GETCHARSETINFO (\\CHARSET CHARCODE) FONTDESC)) (\\CHAR8CODE CHARCODE))))
(PUTPROPS \\FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) (\\FSETWIDTH (|ffetch| (
CHARSETINFO WIDTHS) |of| (\\GETCHARSETINFO (\\CHARSET CHARCODE) FONTDESC)) (\\CHAR8CODE CHARCODE) 
WIDTH)))
(PUTPROPS \\FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE) (\\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE))
)
(PUTPROPS \\FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
(PUTPROPS \\GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?) (* |;;| 
"fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC.  If NIL, then creates the required charset."
) (* |;;| 
"NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL") (OR
 (\\GETBASEPTR (|ffetch| FONTCHARSETVECTOR |of| FONTDESC) (UNFOLD CHARSET 2)) (\\CREATECHARSET CHARSET
 FONTDESC NOSLUG?))))
(PUTPROPS \\CREATECSINFOELEMENT MACRO (NIL (\\ALLOCBLOCK (FOLDHI (IPLUS \\MAXTHINCHAR 3) WORDSPERCELL)
)))
(PUTPROPS \\CREATEFONTCHARSETVECTOR MACRO (NIL (* \; "Allocates a block for the character set records"
) (\\ALLOCBLOCK (ADD1 \\MAXCHARSET) T)))
(DEFMACRO \\CREATEKERNELEMENT NIL (BQUOTE (CL:MAKE-ARRAY (IPLUS \\MAXTHINCHAR 3) :ELEMENT-TYPE (QUOTE 
(SIGNED-BYTE 16)) :INITIAL-ELEMENT 0)))
(DEFMACRO \\FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE) (BQUOTE (CL:SETF (CL:AREF (\\\, LEFTKERNBLOCK
) (\\\, INDEX)) (\\\, KERNVALUE))))
(DEFMACRO \\FGETLEFTKERN (LEFTKERNBLOCK CHAR8CODE) (BQUOTE (CL:AREF (\\\, LEFTKERNBLOCK) (\\\, 
CHAR8CODE))))
(RPAQQ \\MAXNSCHAR 65535)
(CONSTANTS (\\MAXNSCHAR 65535))
(PUTPROP (QUOTE FONT) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:29:49"))

(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)))))
(RPAQQ \\NKEYS 112)
(CONSTANTS \\NKEYS)
(DEFOPTIMIZER KEYDOWNP (KEYNAME) (BQUOTE (\\NEWKEYDOWNP (\\KEYNAMETONUMBER (\\\, KEYNAME)))))
(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))))
(GLOBALVARS \\KEYBOARD.DEVICE \\KEYBOARD.STREAM)
(RPAQQ HARDCURSORHEIGHT 16)
(RPAQQ HARDCURSORWIDTH 16)
(CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16))
(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD)
(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)))))
(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)
(PUTPROP (QUOTE LLKEY) (QUOTE IMPORTDATE) (IDATE "19-May-2018 13:32:12"))

(DATATYPE PILOTBBT ((PBTDESTLO WORD) (PBTDESTHI WORD) (PBTDESTBIT WORD) (PBTDESTBPL SIGNEDWORD) (
PBTSOURCELO WORD) (PBTSOURCEHI WORD) (PBTSOURCEBIT WORD) (PBTSOURCEBPL SIGNEDWORD) (PBTWIDTH WORD) (
PBTHEIGHT WORD) (PBTFLAGS WORD) (NIL 5 WORD)) (BLOCKRECORD PILOTBBT ((NIL 7 WORD) (NIL BITS 4) (
PBTGRAYOFFSET BITS 4) (PBTGRAYWIDTHLESSONE BITS 4) (PBTGRAYHEIGHTLESSONE BITS 4) (NIL 2 WORD) (
PBTBACKWARD FLAG) (PBTDISJOINT FLAG) (PBTDISJOINTITEMS FLAG) (PBTUSEGRAY FLAG) (PBTSOURCETYPE BITS 1) 
(PBTOPERATION BITS 2) (NIL BITS 9))) (ACCESSFNS PILOTBBT ((PBTSOURCE (\\VAG2 (|fetch| PBTSOURCEHI |of|
 DATUM) (|fetch| PBTSOURCELO |of| DATUM)) (PROGN (|replace| PBTSOURCEHI |of| DATUM |with| (\\HILOC 
NEWVALUE)) (|replace| PBTSOURCELO |of| DATUM |with| (\\LOLOC NEWVALUE)))) (PBTDEST (\\VAG2 (|fetch| 
PBTDESTHI |of| DATUM) (|fetch| PBTDESTLO |of| DATUM)) (PROGN (|replace| PBTDESTHI |of| DATUM |with| (
\\HILOC NEWVALUE)) (|replace| PBTDESTLO |of| DATUM |with| (\\LOLOC NEWVALUE)))))) (SYSTEM))
(DATATYPE \\DISPLAYDATA (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET |DDDestination| 
|DDClippingRegion| DDFONT |DDSlowPrintingCase| DDWIDTHSCACHE DDOFFSETSCACHE DDCOLOR DDLINEFEED 
|DDRightMargin| |DDLeftMargin| |DDScroll| DDOPERATION DDSOURCETYPE (|DDClippingLeft| WORD) (
|DDClippingRight| WORD) (|DDClippingBottom| WORD) (|DDClippingTop| WORD) (NIL WORD) (DDHELDFLG FLAG) (
XWINDOWHINT XPOINTER) (DDPILOTBBT POINTER) DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS DDEOLFN DDPAGEFULLFN 
|DDTexture| DDMICAXPOS DDMICAYPOS DDMICARIGHTMARGIN DDCHARSET (DDCHARSETASCENT WORD) (DDCHARSETDESCENT
 WORD) DDCHARHEIGHTDELTA (DDSPACEWIDTH WORD)) DDPILOTBBT _ (|create| PILOTBBT PBTDISJOINT _ T) 
|DDLeftMargin| _ 0 |DDRightMargin| _ SCREENWIDTH DDXPOSITION _ 0 DDYPOSITION _ 0 DDXOFFSET _ 0 
DDYOFFSET _ 0 |DDClippingRegion| _ (|create| REGION) |DDDestination| _ |ScreenBitMap| DDXSCALE _ 1 
DDYSCALE _ 1 |DDTexture| _ 0 (ACCESSFNS ((DDFOREGROUNDCOLOR (PROG ((VAL (|fetch| (\\DISPLAYDATA 
DDCOLOR) |of| DATUM))) (OR (FIXP VAL) (BITMAPP VAL) (AND (NULL VAL) 1) (CAR VAL) (MAXIMUMCOLOR (
BITSPERPIXEL (|fetch| (\\DISPLAYDATA |DDDestination|) |of| DATUM)))))) (DDBACKGROUNDCOLOR (OR (|fetch|
 (\\DISPLAYDATA |DDTexture|) |of| DATUM) 0)))) (SYSTEM))
(RECORD DISPLAYSTATE (ONOFF))
(RECORD DISPLAYINFO (DITYPE DIWIDTH DIHEIGHT DIBITSPERPIXEL DIWSOPS))
(PUTPROPS \\GETDISPLAYDATA MACRO (ARGS (COND ((CADR ARGS) (SUBPAIR (QUOTE (STRM STRMVAR)) ARGS (QUOTE 
(\\DTEST (|fetch| (STREAM IMAGEDATA) |of| (SETQ STRMVAR (\\OUTSTREAMARG STRM))) (QUOTE \\DISPLAYDATA))
))) (T (SUBST (CAR ARGS) (QUOTE STRM) (QUOTE (\\DTEST (|fetch| (STREAM IMAGEDATA) |of| (\\OUTSTREAMARG
 STRM)) (QUOTE \\DISPLAYDATA))))))))
(PUTPROPS \\BITMASK MACRO ((N) (\\WORDELT BITMASKARRAY (LOGAND N 15))))
(PUTPROPS \\4BITMASK MACRO ((N) (\\WORDELT 4BITMASKARRAY (LOGAND N 3))))
(PUTPROPS \\NOTBITMASK MACRO ((N) (DECLARE (GLOBALVARS NOTBITMASKARRAY)) (\\WORDELT NOTBITMASKARRAY (
LOGAND N 15))))
(PUTPROPS \\NOT4BITMASK MACRO ((N) (\\WORDELT NOT4BITMASKARRAY (LOGAND N 3))))
(GLOBALVARS BITMASKARRAY NOTBITMASKARRAY 4BITMASKARRAY NOT4BITMASKARRAY)
(RPAQQ WORDMASK 65535)
(CONSTANTS (WORDMASK 65535))
(PUTPROPS \\INVALIDATEDISPLAYCACHE MACRO ((DISPLAYDATA) (* |This| |marks| |the| |character-printing| 
|caches| |of| |the| |displaystream| |as| |invalid.| |Needed| |when| |the| |font| |or| Y |position| 
|changes|) (|freplace| (\\DISPLAYDATA DDCHARSET) |of| DISPLAYDATA |with| MAX.SMALLP) (|freplace| (
\\DISPLAYDATA DDCHARSETASCENT) |of| DISPLAYDATA |with| MAX.SMALLP)))
(PUTPROPS \\DSPGETCHARWIDTH MACRO ((CHARCODE DD) (\\FGETWIDTH (|ffetch| (\\DISPLAYDATA DDWIDTHSCACHE) 
|of| DD) CHARCODE)))
(PUTPROPS \\DSPGETCHARIMAGEWIDTH MACRO ((CHARCODE DD) (\\FGETIMAGEWIDTH (|ffetch| (\\DISPLAYDATA 
DDCHARIMAGEWIDTHS) |of| DD) CHARCODE)))
(PUTPROPS \\DSPGETCHAROFFSET MACRO ((CHARCODE DD) (\\GETBASE (|ffetch| (\\DISPLAYDATA DDOFFSETSCACHE) 
|of| DD) CHARCODE)))
(PUTPROPS \\CONVERTOP MACRO ((OP) (* |rrb| "14-NOV-80 11:14") (* |Only| |for| |alto| |bitblt| !!) (
SELECTQ OP (|replace| 0 |of| NIL |with| NIL) (PAINT 1) (INVERT 2) (ERASE 3) 0)))
(PUTPROPS |\\SFInvert| MACRO ((|BitMap| \y) (* |corrects| |for| |the| |fact| |that| |alto| |bitmaps| 
|are| |stored| |with| 0\,0 |as| |upper| |left| |while| |lisp| |bitmaps| |have| 0\,0 |as| |lower| 
|left.| |The| |correction| |is| |actually| |off| |by| |one| (|greater|) |because| \a |majority| |of| 
|the| |places| |that| |it| |is| |called| |actually| |need| |one| |more| |than| |corrected| Y |value.|)
 (IDIFFERENCE (|fetch| (BITMAP BITMAPHEIGHT) |of| |BitMap|) \y)))
(PUTPROPS |\\SFReplicate| MACRO (LAMBDA (|pattern|) (LOGOR |pattern| (LLSH |pattern| 8) (SETQ 
|pattern| (LLSH |pattern| 4)) (LLSH |pattern| 8))))
(PUTPROPS \\SETPBTFUNCTION MACRO (OPENLAMBDA (BBT |SourceType| |Operation|) (PROGN (|replace| (
PILOTBBT PBTOPERATION) |of| BBT |with| (SELECTQ |Operation| (ERASE 1) (PAINT 2) (INVERT 3) 0)) (
|replace| (PILOTBBT PBTSOURCETYPE) |of| BBT |with| (COND ((EQ (EQ |SourceType| (QUOTE INVERT)) (EQ 
|Operation| (QUOTE ERASE))) 0) (T 1))))))
(PUTPROPS \\BITBLT1 MACRO ((|bbt|) (|BitBltSUBR| |bbt|)))
(PUTPROP (QUOTE BITBLT) (QUOTE MACRO) (QUOTE (= . BKBITBLT)))
(PROGN (PUTPROPS \\INSURETOPWDS DMACRO (OPENLAMBDA (DS) (OR (EQ DS \\TOPWDS) (COND ((FMEMB (
DSPDESTINATION NIL DS) \\SCREENBITMAPS) (\\TOTOPWDS DS)))))) (PUTPROPS \\INSURETOPWDS MACRO ((DS) (* 
|For| |non-window| |implementations|) (PROGN))))
(PUTPROPS .WHILE.TOP.DS. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* FIRST |should| 
|be| \a |displaystream| |and| \a |variable.| |This| |macro| |may| |also| |take| \a |soft| |cursor| 
|down,| |similar| |to| |the| |way| .WHILE.CURSOR.DOWN. |does,| |but| |only| |if| |FIRST's| 
|destination| |is| |the| |same| |as| |the| |soft| |cursor's| |destination.| *) (COND (\\SOFTCURSORP (
SETQ SOFTCURSORUP (AND \\SOFTCURSORUPP (EQ (DSPDESTINATION NIL FIRST) \\CURSORDESTINATION))) (COND (
SOFTCURSORUP (SETQ DISPINTERRUPT (\\GETBASE \\EM.DISPINTERRUPT 0)) (\\PUTBASE \\EM.DISPINTERRUPT 0 0) 
(\\SOFTCURSORDOWN))))) (\\INSURETOPWDS FIRST) (PROGN . REST) (COND (SOFTCURSORUP (
\\SOFTCURSORUPCURRENT) (\\PUTBASE \\EM.DISPINTERRUPT 0 DISPINTERRUPT))))))
(PUTPROPS .WHILE.CURSOR.DOWN. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* |This| 
|macro| |should| |wrap| |around| |any| |code| |that| |draws| |or| |bitblts| |directly| |from| |or| 
|to| \a |screen| |bitmap.| E.\g. DRAWGRAYBOX |in| HLDISPLAY |which| |puts| |up| \a |shadow| |box| 
|during| GETREGION. |The| |purpose| |of| |this| |macro| |is| |that| \a |soft| (|e.g.| |color|) 
|cursor's| |bits| |not| |be| |taken| |to| |be| |screen| |bits| |while| FIRST & REST |are| |done.| *) (
COND (\\SOFTCURSORP (SETQ SOFTCURSORUP \\SOFTCURSORUPP) (COND (SOFTCURSORUP (SETQ DISPINTERRUPT (
\\GETBASE \\EM.DISPINTERRUPT 0)) (\\PUTBASE \\EM.DISPINTERRUPT 0 0) (\\SOFTCURSORDOWN))))) (PROGN 
FIRST . REST) (COND (SOFTCURSORUP (\\SOFTCURSORUPCURRENT) (\\PUTBASE \\EM.DISPINTERRUPT 0 
DISPINTERRUPT))))))
(ADDTOVAR GLOBALVARS \\TOPWDS)
(DEFOPTIMIZER TTYDISPLAYSTREAM (&REST X) (COND ((NULL (CAR X)) (QUOTE \\TERM.OFD)) (T (QUOTE 
IGNOREMACRO))))
(GLOBALVARS BELLCNT BELLRATE TTYBACKGROUNDFNS |\\DisplayStoppedForLogout| \\CARET.UP)
(PUTPROPS \\CHECKCARET MACRO ((X) (AND \\CARET.UP (\\CARET.DOWN X))))
(PUTPROPS \\DSPTRANSFORMX MACRO ((X DD) (* |transforms| |an| \x |coordinate| |into| |the| 
|destination| |coordinate.|) (IPLUS X (|fetch| (\\DISPLAYDATA DDXOFFSET) |of| DD))))
(PUTPROPS \\DSPTRANSFORMY MACRO ((Y DD) (* |transforms| |an| \y |coordinate| |into| |the| 
|destination| |coordinate.|) (IPLUS Y (|fetch| (\\DISPLAYDATA DDYOFFSET) |of| DD))))
(PUTPROPS \\OFFSETBOTTOM MACRO ((X) (* |gives| |the| |destination| |coordinate| |address| |of| |the| 
|origin.|) (|fetch| (\\DISPLAYDATA DDYOFFSET) |of| X)))
(PUTPROPS \\OFFSETLEFT MACRO ((DD) (* |returns| |the| \x |origin| |of| |display| |data| |destination| 
|coordinates.|) (|fetch| (\\DISPLAYDATA DDXOFFSET) |of| DD)))
(PUTPROPS DISPLAYINITIALIZEDP MACRO (NIL (* |always| |initialized| |now|) T))
(PUTPROPS DISPLAYSTARTEDP MACRO (NIL |\\DisplayStarted|))
(GLOBALVARS |\\DisplayStarted| |\\DisplayStreamsInitialized| |\\DisplayInitialed| WHOLEDISPLAY 
WHOLESCREEN SCREENWIDTH SCREENHEIGHT)
(PUTPROP (QUOTE LLDISPLAY) (QUOTE IMPORTDATE) (IDATE "18-Apr-1994 00:20:42"))

(RECORD REGION (LEFT BOTTOM WIDTH HEIGHT) LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767 (
ACCESSFNS ((TOP (IPLUS (|fetch| (REGION BOTTOM) |of| DATUM) (|fetch| (REGION HEIGHT) |of| DATUM) -1)) 
(PTOP (IPLUS (|fetch| (REGION BOTTOM) |of| DATUM) (|fetch| (REGION HEIGHT) |of| DATUM))) (RIGHT (IPLUS
 (|fetch| (REGION LEFT) |of| DATUM) (|fetch| (REGION WIDTH) |of| DATUM) -1)) (PRIGHT (IPLUS (|fetch| (
REGION LEFT) |of| DATUM) (|fetch| (REGION WIDTH) |of| DATUM))))) (TYPE? (AND (EQLENGTH DATUM 4) (EVERY
 DATUM (FUNCTION NUMBERP)))) (SYSTEM))
(DATATYPE BITMAP ((BITMAPBASE POINTER) (BITMAPRASTERWIDTH WORD) (BITMAPHEIGHT WORD) (BITMAPWIDTH WORD)
 (BITMAPBITSPERPIXEL WORD)) BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((|BitMapHiLoc| WORD) (
|BitMapLoLoc| WORD)) (* \; "overlay initial pointer")) (SYSTEM))
(BLOCKRECORD BITMAPWORD ((BITS WORD)) (SYSTEM))
(RECORD POSITION (XCOORD . YCOORD) (TYPE? (AND (LISTP DATUM) (NUMBERP (CAR DATUM)) (NUMBERP (CDR DATUM
)))) (SYSTEM))
(DATATYPE CURSOR (CUIMAGE CUMASK CUHOTSPOTX CUHOTSPOTY CUDATA) (ACCESSFNS ((CUBITSPERPIXEL (|fetch| (
BITMAP BITMAPBITSPERPIXEL) |of| (|fetch| (CURSOR CUIMAGE) |of| DATUM))))) (SYSTEM))
(RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME) (SYSTEM))
(RECORD SCREENREGION (SCREEN . REGION) (SUBRECORD REGION) (TYPE? (AND (LISTP DATUM) (|type?| SCREEN (
CAR DATUM)) (|type?| REGION (CDR DATUM)))) (SYSTEM))
(RECORD SCREENPOSITION (SCREEN . POSITION) (SUBRECORD POSITION) (TYPE? (AND (LISTP DATUM) (|type?| 
SCREEN (CAR DATUM)) (|type?| POSITION (CDR DATUM)))) (SYSTEM))
(PUTPROPS CURSORBITMAP MACRO (NIL |CursorBitMap|))
(RPAQQ HARDCURSORHEIGHT 16)
(RPAQQ HARDCURSORWIDTH 16)
(CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16))
(ADDTOVAR GLOBALVARS |CursorBitMap|)
(ARRAYRECORD POLYNOMIAL (A B C D) (CREATE (ARRAY 4 (QUOTE FLOATP))) (SYSTEM))
(RECORD SPLINE (\#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY))
(PUTPROPS HALF MACRO ((X) (LRSH X 1)))
(PUTPROPS \\FILLCIRCLEBLT MACRO (OPENLAMBDA (CX CY X Y) (* \; 
"calls bitblt twice to fill in one line of the circle.") (\\LINEBLT FCBBT (IDIFFERENCE CX X) (IPLUS CY
 Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS
) (\\LINEBLT FCBBT (IDIFFERENCE CX X) (IDIFFERENCE CY Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT
 RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)))
(PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (VARS . X))))))
(PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (E (MAPC (QUOTE X) (QUOTE 
PRINTCURSOR))))))))
(ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH |ScreenBitMap|)
(RPAQQ BLACKSHADE 65535)
(RPAQQ WHITESHADE 0)
(CONSTANTS (BLACKSHADE 65535) (WHITESHADE 0))
(RPAQQ GRAYSHADE 43605)
(ADDTOVAR GLOBALVARS GRAYSHADE)
(RECORD HLS (HUE LIGHTNESS SATURATION))
(RECORD RGB (RED GREEN BLUE))
(PUTPROP (QUOTE ADISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Sep-1994 17:07:04"))

(ADDTOVAR SYSSPECVARS \\INTERRUPTABLE)
(PUTPROPS UNINTERRUPTABLY INFO EVAL)
(PUTPROPS UNINTERRUPTABLY DMACRO ((X . Y) ((LAMBDA (\\INTERRUPTABLE) (PROGN X . Y)) NIL)))
(ADDTOVAR PRETTYPRINTMACROS (UNINTERRUPTABLY LAMBDA (FORM) (PROG ((POS (IPLUS 4 (POSITION)))) (PRIN1 
"(") (PRIN2 (CAR FORM)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM (CDR FORM)))) (TAB POS 0)) (PRINTDEF FORM 
POS T T FNSLST) (PRIN1 ")"))))
(BLOCKRECORD INTERRUPTSTATE ((* |;;| 
"This is the structure used to communicate between the emulator and Lisp re interrupts.  There is a bit per interrupt type, plus space for the character code that caused a keyboard interrupt."
) (* |;;| "This must match the INTSTAT definition in lispemul.h") (* |;;| "PENDING-INTERRUPT FLAGS:") 
(LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.") (ETHERINTERRUPT FLAG) (* \; 
"Ether packet read finished.") (IOINTERRUPT FLAG) (GCDISABLED FLAG) (* \; "No mroe room in GC tables."
) (VMEMFULL FLAG) (* \; "VMEM is full!!") (STACKOVERFLOW FLAG) (* \; "Stack overflowed.") (STORAGEFULL
 FLAG) (* \; "Ran out of storage, atoms, etc.") (WAITINGINTERRUPT FLAG) (* |;;| 
"INTERRUPTS-IN-PROCESS MASK:") (P-LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.") (
P-ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.") (P-IOINTERRUPT FLAG) (P-GCDISABLED FLAG) (
* \; "No mroe room in GC tables.") (P-VMEMFULL FLAG) (* \; "VMEM is full!!") (P-STACKOVERFLOW FLAG) (*
 \; "Stack overflowed.") (P-STORAGEFULL FLAG) (* \; "Ran out of storage, atoms, etc.") (
P-WAITINGINTERRUPT FLAG) (INTCHARCODE WORD)) (BLOCKRECORD INTERRUPTSTATE ((* |;;| 
"Alternative view of the structure:") (PENDING BITS 8) (* \; "Pending-interrupt flags") (IN-PROGRESS 
BITS 8) (* \; "Mask to prevent re-interrupt for an interrupt in progress") (NIL WORD))))
(PUTPROPS \\TAKEINTERRUPT DMACRO ((PREFORM POSTFORM) (DECLARE (GLOBALVARS \\PENDINGINTERRUPT)) (COND (
(AND \\PENDINGINTERRUPT (INTERRUPTABLE~=NILUPTHESTACK)) PREFORM ((LAMBDA (\\INTERRUPTABLE) (
\\CALLINTERRUPTED)) T) POSTFORM))))
(PUTPROP (QUOTE AINTERRUPT) (QUOTE IMPORTDATE) (IDATE "17-Sep-1992 10:42:38"))

(ACCESSFNS PUP ((PUPBASE (LOCF (|fetch| (ETHERPACKET EPBODY) |of| DATUM)))) (BLOCKRECORD PUPBASE ((
PUPLENGTH WORD) (PUPTCONTROL BYTE) (PUPTYPE BYTE) (PUPID FIXP) (PUPDEST WORD) (PUPDESTSOCKET FIXP) (
PUPSOURCE WORD) (PUPSOURCESOCKET FIXP) (PUPDATASTART 266 WORD)) (BLOCKRECORD PUPBASE ((NIL WORD) (
TYPEWORD WORD) (PUPIDHI WORD) (PUPIDLO WORD) (PUPDESTNET BYTE) (PUPDESTHOST BYTE) (PUPDESTSOCKETHI 
WORD) (PUPDESTSOCKETLO WORD) (PUPSOURCENET BYTE) (PUPSOURCEHOST BYTE) (PUPSOURCESOCKETHI WORD) (
PUPSOURCESOCKETLO WORD)) (* \; "Temporary extra synonyms") (SYNONYM PUPDESTNET (DESTNET)) (SYNONYM 
PUPDESTHOST (DESTHOST)) (SYNONYM PUPDESTSOCKETHI (DESTSKTHI)) (SYNONYM PUPDESTSOCKETLO (DESTSKTLO)) (
SYNONYM PUPSOURCENET (SOURCENET)) (SYNONYM PUPSOURCEHOST (SOURCEHOST)) (SYNONYM PUPSOURCESOCKETHI (
SOURCESKTHI)) (SYNONYM PUPSOURCESOCKETLO (SOURCESKTLO))) (SYNONYM PUPDEST (DEST)) (SYNONYM 
PUPDESTSOCKET (DESTSKT)) (SYNONYM PUPSOURCE (SOURCE)) (SYNONYM PUPSOURCESOCKET (SOURCESKT)) (ACCESSFNS
 PUPDATASTART ((PUPCONTENTS (LOCF DATUM))))) (ACCESSFNS PUP ((PUPCHECKSUMBASE (|fetch| PUPBASE |of| 
DATUM)) (PUPCHECKSUMLOC (\\ADDBASE (|fetch| PUPBASE |of| DATUM) (FOLDLO (SUB1 (|fetch| PUPLENGTH |of| 
DATUM)) BYTESPERWORD)))) (BLOCKRECORD PUPCHECKSUMLOC ((PUPCHECKSUM WORD)))) (TYPE? (|type?| 
ETHERPACKET DATUM)))
(ACCESSFNS PUPADDRESS ((PUPNET# (LRSH DATUM 8)) (PUPHOST# (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH 
PUPNET# 8) PUPHOST#)))
(PUTPROPS \\LOCALPUPADDRESS MACRO (NIL \\LOCALPUPNETHOST))
(PUTPROPS \\LOCALPUPHOSTNUMBER MACRO (NIL (|fetch| PUPHOST# |of| \\LOCALPUPNETHOST)))
(PUTPROPS \\LOCALPUPNETNUMBER MACRO (NIL (|fetch| PUPNET# |of| \\LOCALPUPNETHOST)))
(ACCESSFNS ERRORPUP ((ERRORPUPBASE (|fetch| PUPCONTENTS |of| DATUM))) (BLOCKRECORD ERRORPUPBASE ((
ERRORPUPCOPY 10 WORD) (* \; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* \; 
"Usually zero") (ERRORPUPSTRINGBASE WORD) (* \; "Human readable message"))))
(RPAQQ PUPERRORCODES ((\\PUPE.CHECKSUM 1) (\\PUPE.NOSOCKET 2) (\\PUPE.SOCKETFULL 3) (
\\PUPE.GATEWAY.BADPUP 513) (\\PUPE.NOROUTE 514) (\\PUPE.NOHOST 515) (\\PUPE.LOOPED 516) (
\\PUPE.TOOLARGE 517) (\\PUPE.WRONG.GATEWAY 518) (\\PUPE.GATEWAYFULL 519)))
(RPAQQ \\PUPE.CHECKSUM 1)
(RPAQQ \\PUPE.NOSOCKET 2)
(RPAQQ \\PUPE.SOCKETFULL 3)
(RPAQQ \\PUPE.GATEWAY.BADPUP 513)
(RPAQQ \\PUPE.NOROUTE 514)
(RPAQQ \\PUPE.NOHOST 515)
(RPAQQ \\PUPE.LOOPED 516)
(RPAQQ \\PUPE.TOOLARGE 517)
(RPAQQ \\PUPE.WRONG.GATEWAY 518)
(RPAQQ \\PUPE.GATEWAYFULL 519)
(CONSTANTS (\\PUPE.CHECKSUM 1) (\\PUPE.NOSOCKET 2) (\\PUPE.SOCKETFULL 3) (\\PUPE.GATEWAY.BADPUP 513) (
\\PUPE.NOROUTE 514) (\\PUPE.NOHOST 515) (\\PUPE.LOOPED 516) (\\PUPE.TOOLARGE 517) (
\\PUPE.WRONG.GATEWAY 518) (\\PUPE.GATEWAYFULL 519))
(PUTPROPS BINDPUPS MACRO (X (CONS (LIST (QUOTE LAMBDA) (CAR X) (CONS (QUOTE PROGN) (CDR X))) (|in| (
CAR X) |collect| (LIST (QUOTE ALLOCATE.PUP))))))
(PUTPROPS BINDPUPS INFO BINDS)
(ADDTOVAR PRETTYPRINTMACROS (BINDPUPS LAMBDA (FORM) (PROG ((POS (IPLUS 2 (POSITION)))) (PRIN1 "(") (
PRIN2 (CAR FORM)) (SPACES 1) (PRINTDEF (CADR FORM) (POSITION)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM (
CDDR FORM)))) (TAB POS 0)) (PRINTDEF FORM POS T T FNSLST) (PRIN1 ")"))))
(BLOCKRECORD PORT ((NETHOST WORD) (SOCKET FIXP)) (BLOCKRECORD PORT ((NET BYTE) (HOST BYTE) (SOCKETHI 
WORD) (SOCKETLO WORD))))
(ACCESSFNS ERRORPUP ((ERRORPUPBASE (|fetch| PUPCONTENTS |of| DATUM))) (BLOCKRECORD ERRORPUPBASE ((
ERRORPUPCOPY 10 WORD) (* \; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* \; 
"Usually zero") (ERRORPUPSTRINGBASE WORD) (* \; "Human readable message"))))
(GLOBALVARS \\ETHERWAIT1 \\ETHERTIMEOUT \\MAXETHERTRIES PUPTRACEFLG LOGINPASSWORDS)
(GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS)
(RPAQQ \\PUPOVLEN 22)
(RPAQQ \\MAX.PUPLENGTH 532)
(RPAQQ \\TIME.GETPUP 5)
(CONSTANTS (\\PUPOVLEN 22) (\\MAX.PUPLENGTH 532) (\\TIME.GETPUP 5))
(PUTPROPS PUPPRINTMACROS VARTYPE ALIST)
(PUTPROPS \\GETPUPWORD DMACRO ((PUP WORD#) (\\GETBASE (|fetch| PUPCONTENTS |of| PUP) WORD#)))
(PUTPROPS \\PUTPUPWORD DMACRO ((PUP WORD# VALUE) (\\PUTBASE (|fetch| PUPCONTENTS |of| PUP) WORD# VALUE
)))
(PUTPROPS \\GETPUPBYTE DMACRO ((PUP BYTE#) (\\GETBASEBYTE (|fetch| PUPCONTENTS |of| PUP) BYTE#)))
(PUTPROPS \\PUTPUPBYTE DMACRO ((PUP BYTE# VALUE) (\\PUTBASEBYTE (|fetch| PUPCONTENTS |of| PUP) BYTE# 
VALUE)))
(RPAQQ RAWPUPTYPES ((\\PT.ECHOME 1) (\\PT.IAMECHO 2) (\\PT.IAMBADECHO 3) (\\PT.ERROR 4) (\\PT.RFC 8) (
\\PT.ABORT 9) (\\PT.END 10) (\\PT.ENDREPLY 11) (\\PT.DATA 16) (\\PT.ADATA 17) (\\PT.ACK 18) (\\PT.MARK
 19) (\\PT.INTERRUPT 20) (\\PT.INTERRUPTREPLY 21) (\\PT.AMARK 22) (\\PT.GATEWAYREQUEST 128) (
\\PT.GATEWAYRESPONSE 129) (\\PT.ALTOTIMEREQUEST 134) (\\PT.ALTOTIMERESPONSE 135) (\\PT.MSGCHECK 136) (
\\PT.NEWMAIL 137) (\\PT.NONEWMAIL 138) (\\PT.NOMAILBOX 139) (\\PT.LAURELCHECK 140) (\\PT.NAMELOOKUP 
144) (\\PT.NAMERESPONSE 145) (\\PT.NAME/ADDRERROR 146) (\\PT.ADDRLOOKUP 147) (\\PT.ADDRRESPONSE 148) (
\\PT.PRINTERSTATUS 128) (\\PT.STATUSRESPONSE 129) (\\PT.PRINTERCAPABILITY 130) (
\\PT.CAPABILITYRESPONSE 131) (\\PT.PRINTJOBSTATUS 132) (\\PT.PRINTJOBRESPONSE 133)))
(RPAQQ \\PT.ECHOME 1)
(RPAQQ \\PT.IAMECHO 2)
(RPAQQ \\PT.IAMBADECHO 3)
(RPAQQ \\PT.ERROR 4)
(RPAQQ \\PT.RFC 8)
(RPAQQ \\PT.ABORT 9)
(RPAQQ \\PT.END 10)
(RPAQQ \\PT.ENDREPLY 11)
(RPAQQ \\PT.DATA 16)
(RPAQQ \\PT.ADATA 17)
(RPAQQ \\PT.ACK 18)
(RPAQQ \\PT.MARK 19)
(RPAQQ \\PT.INTERRUPT 20)
(RPAQQ \\PT.INTERRUPTREPLY 21)
(RPAQQ \\PT.AMARK 22)
(RPAQQ \\PT.GATEWAYREQUEST 128)
(RPAQQ \\PT.GATEWAYRESPONSE 129)
(RPAQQ \\PT.ALTOTIMEREQUEST 134)
(RPAQQ \\PT.ALTOTIMERESPONSE 135)
(RPAQQ \\PT.MSGCHECK 136)
(RPAQQ \\PT.NEWMAIL 137)
(RPAQQ \\PT.NONEWMAIL 138)
(RPAQQ \\PT.NOMAILBOX 139)
(RPAQQ \\PT.LAURELCHECK 140)
(RPAQQ \\PT.NAMELOOKUP 144)
(RPAQQ \\PT.NAMERESPONSE 145)
(RPAQQ \\PT.NAME/ADDRERROR 146)
(RPAQQ \\PT.ADDRLOOKUP 147)
(RPAQQ \\PT.ADDRRESPONSE 148)
(RPAQQ \\PT.PRINTERSTATUS 128)
(RPAQQ \\PT.STATUSRESPONSE 129)
(RPAQQ \\PT.PRINTERCAPABILITY 130)
(RPAQQ \\PT.CAPABILITYRESPONSE 131)
(RPAQQ \\PT.PRINTJOBSTATUS 132)
(RPAQQ \\PT.PRINTJOBRESPONSE 133)
(CONSTANTS (\\PT.ECHOME 1) (\\PT.IAMECHO 2) (\\PT.IAMBADECHO 3) (\\PT.ERROR 4) (\\PT.RFC 8) (
\\PT.ABORT 9) (\\PT.END 10) (\\PT.ENDREPLY 11) (\\PT.DATA 16) (\\PT.ADATA 17) (\\PT.ACK 18) (\\PT.MARK
 19) (\\PT.INTERRUPT 20) (\\PT.INTERRUPTREPLY 21) (\\PT.AMARK 22) (\\PT.GATEWAYREQUEST 128) (
\\PT.GATEWAYRESPONSE 129) (\\PT.ALTOTIMEREQUEST 134) (\\PT.ALTOTIMERESPONSE 135) (\\PT.MSGCHECK 136) (
\\PT.NEWMAIL 137) (\\PT.NONEWMAIL 138) (\\PT.NOMAILBOX 139) (\\PT.LAURELCHECK 140) (\\PT.NAMELOOKUP 
144) (\\PT.NAMERESPONSE 145) (\\PT.NAME/ADDRERROR 146) (\\PT.ADDRLOOKUP 147) (\\PT.ADDRRESPONSE 148) (
\\PT.PRINTERSTATUS 128) (\\PT.STATUSRESPONSE 129) (\\PT.PRINTERCAPABILITY 130) (
\\PT.CAPABILITYRESPONSE 131) (\\PT.PRINTJOBSTATUS 132) (\\PT.PRINTJOBRESPONSE 133))
(RPAQ? PUPTYPES RAWPUPTYPES)
(RPAQQ WELLKNOWNPUPSOCKETS ((\\PUPSOCKET.TELNET 1) (\\PUPSOCKET.ROUTING 2) (\\PUPSOCKET.FTP 3) (
\\PUPSOCKET.MISCSERVICES 4) (\\PUPSOCKET.ECHO 5) (\\PUPSOCKET.EFTP 16) (\\PUPSOCKET.PRINTERSTATUS 17) 
(\\PUPSOCKET.LEAF 35)))
(RPAQQ \\PUPSOCKET.TELNET 1)
(RPAQQ \\PUPSOCKET.ROUTING 2)
(RPAQQ \\PUPSOCKET.FTP 3)
(RPAQQ \\PUPSOCKET.MISCSERVICES 4)
(RPAQQ \\PUPSOCKET.ECHO 5)
(RPAQQ \\PUPSOCKET.EFTP 16)
(RPAQQ \\PUPSOCKET.PRINTERSTATUS 17)
(RPAQQ \\PUPSOCKET.LEAF 35)
(CONSTANTS (\\PUPSOCKET.TELNET 1) (\\PUPSOCKET.ROUTING 2) (\\PUPSOCKET.FTP 3) (
\\PUPSOCKET.MISCSERVICES 4) (\\PUPSOCKET.ECHO 5) (\\PUPSOCKET.EFTP 16) (\\PUPSOCKET.PRINTERSTATUS 17) 
(\\PUPSOCKET.LEAF 35))
(PUTPROP (QUOTE PUP) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 11:14:09"))

(PUTPROPS UNLESSRDSYS MACRO ((NORMAL RDSYS) NORMAL))
(PUTPROPS UNLESSINEW MACRO ((NORMAL I-NEW) NORMAL))
(PUTPROPS 1ST MACRO ((A . B) A))
(PUTPROPS 2ND MACRO ((A B . C) B))
(PUTPROPS LOCAL MACRO ((X) X))
(PUTPROPS ALLOCAL MACRO ((X) X))
(PUTPROPS ADDBASE DMACRO (= . \\ADDBASE))
(PUTPROPS GETBASE DMACRO (= . \\GETBASE))
(PUTPROPS GETBASEBYTE DMACRO (= . \\GETBASEBYTE))
(PUTPROPS GETBASEPTR DMACRO (= . \\GETBASEPTR))
(PUTPROPS HILOC DMACRO (= . \\HILOC))
(PUTPROPS LOLOC DMACRO (= . \\LOLOC))
(PUTPROPS PUTBASE DMACRO (= . \\PUTBASE))
(PUTPROPS PUTBASEBYTE DMACRO (= . \\PUTBASEBYTE))
(PUTPROPS PUTBASEPTR DMACRO (= . \\PUTBASEPTR))
(PUTPROPS REPLACEPTRFIELD DMACRO (= . \\RPLPTR))
(PUTPROPS VAG2 DMACRO (= . \\VAG2))
(PUTPROPS PAGEBASE MACRO ((PTR) (|fetch| (POINTER PAGEBASE) |of| PTR)))
(PUTPROPS PAGELOC MACRO (OPENLAMBDA (PTR) (IPLUS (LLSH (\\HILOC PTR) 8) (LRSH (\\LOLOC PTR) 8))))
(PUTPROP (QUOTE RENAMEMACROS) (QUOTE IMPORTDATE) (IDATE "27-Apr-1994 15:43:27"))

(PUTPROPS MOUSESTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR 
ARGS) T))))
(PUTPROPS LASTMOUSESTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS) T)))
(PUTPROPS UNTILMOUSESTATE MACRO (ARGS (COND ((AND (CDR ARGS) (CADR ARGS) (NEQ (CADR ARGS) T)) (* 
|time| |argument| |is| |given| |and| |is| |not| T |or| NIL\; |compile| |in| |time| |keeping| |loop.|) 
(LIST (QUOTE PROG) (LIST (LIST (QUOTE TIMEOUT) (LIST (QUOTE IPLUS) (QUOTE (CLOCK 0)) (LIST (QUOTE OR) 
(LIST (QUOTE NUMBERP) (CADR ARGS)) 100))) (QUOTE (NOWTIME (CLOCK 0)))) (QUOTE LP) (LIST (QUOTE COND) (
LIST (CONS (QUOTE MOUSESTATE) (LIST (CAR ARGS) T)) (QUOTE (RETURN T)))) (QUOTE (COND ((IGREATERP (
CLOCK0 NOWTIME) TIMEOUT) (RETURN NIL)) (T (\\BACKGROUND)))) (QUOTE (GO LP)))) (T (LIST (QUOTE PROG) 
NIL (QUOTE LP) (LIST (QUOTE COND) (LIST (CONS (QUOTE MOUSESTATE) (LIST (CAR ARGS) T)) (QUOTE (RETURN T
)))) (QUOTE (\\BACKGROUND)) (QUOTE (GO LP)))))))
(PUTPROPS KEYSETSTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR 
ARGS)))))
(PUTPROPS LASTKEYSETSTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS))))
(PUTPROPS WITHIN MACRO ((A B C) (AND (IGEQ A B) (ILESSP A (IPLUS B C)))))
(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS)
(PUTPROPS IABS MACRO (OPENLAMBDA (A) (COND ((IGEQ A 0) A) (T (IMINUS A)))))
(PUTPROP (QUOTE HLDISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Mar-1994 10:48:02"))

(PUTPROPS .COPYKEYDOWNP. MACRO (NIL (OR (KEYDOWNP (QUOTE LSHIFT)) (KEYDOWNP (QUOTE RSHIFT)) (KEYDOWNP 
(QUOTE COPY)))))
(PUTPROPS WSOP MACRO (ARGS (LET ((METHOD (CADR (CAR ARGS))) (DISPLAY (CADR ARGS)) (OTHERARGS (CDDR 
ARGS))) (BQUOTE (SPREADAPPLY* (|fetch| (WSOPS (\\\, METHOD)) |of| (|fetch| (FDEV WINDOWOPS) |of| (\\\,
 DISPLAY))) (\\\, DISPLAY) (\\\,@ OTHERARGS))))))
(PUTPROPS \\COERCETODS MACRO (OPENLAMBDA (X) (COND ((|type?| WINDOW X) (|fetch| (WINDOW DSP) |of| X)) 
(T (\\ILLEGAL.ARG X)))))
(PUTPROPS .WHILE.ON.TOP. MACRO ((FIRST . REST) (UNINTERRUPTABLY (\\INTERNALTOTOPW FIRST) . REST)))
(PUTPROPS WINDOWOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS
))) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (|fetch| (SCREEN
 (\\\, (CADR OPNAME))) |of| (\\\, METHOD-DEVICE)) (\\\, METHOD-DEVICE) (\\\,@ TAIL)))) (T (ERROR 
"OPNAME not quoted: " OPNAME))))))
(RPAQQ |MinWindowWidth| 26)
(RPAQQ |MinWindowHeight| 16)
(CONSTANTS (|MinWindowWidth| 26) (|MinWindowHeight| 16))
(DATATYPE WINDOW (DSP (* \; "The display stream you use to actually printto the window.") NEXTW (* \; 
"Next window in the open-window list") SAVE (* \; "Saved image from anything this window's on top of")
 REG (* \; "Screen region this window occupies") BUTTONEVENTFN (* \; 
"FN called when left/middle mouse button goes up/down") RIGHTBUTTONFN (* \; 
"FN called when right mouse button goes up/down") CURSORINFN (* \; 
"Fn called when mouse enters window") CURSOROUTFN (* \; "Called when mouse leaves window") 
CURSORMOVEDFN (* \; "Called when mouse moves in window") REPAINTFN (* \; 
"Redisplay part of thie window") RESHAPEFN (* \; "Called when window is reshaped") EXTENT (* \; 
"Scrolling limits") USERDATA (* \; "Proplist to hold other window properites") VERTSCROLLREG (* \; 
"Region of vert scroll bar") HORIZSCROLLREG (* \; "Tegion of horiz scroll bar") SCROLLFN (* \; 
"Fn to scroll this window") VERTSCROLLWINDOW (* \; "Vert scroll bar") HORIZSCROLLWINDOW (* \; 
"Horiz scroll bar") CLOSEFN (* \; "Called at close time") MOVEFN (* \; "Called when window is moved") 
WTITLE (* \; "Window's title string, if any") NEWREGIONFN (* \; "Called to get new window shape") 
WBORDER (* \; "Window border-width, in pixels") PROCESS (* \; 
"Medley process associated with this window") WINDOWENTRYFN (* \; 
"Fn to call when kbd focus is switched here") SCREEN (* \; "Screen this window appears on") (
NATIVE-HANDLE FIXP) (* \; 
"Uniterpreted place for native window to store a C pointer to its private info") (NATIVE-INFO1 FIXP) (
* \; "Reserved in case the pointer must be 64 bits") (NATIVE-W1 WORD) (* \; 
"Word for use by native handler") (NATIVE-W2 WORD) (* \; "Word for use by native handler") (NATIVE-P1 
POINTER) (* \; "Lisp pointer for use by native handler")) BUTTONEVENTFN _ (FUNCTION TOTOPW) WBORDER _ 
|WBorder| WINDOWENTRYFN _ (FUNCTION GIVE.TTY.PROCESS) (SYSTEM))
(DATATYPE SCREEN (SCONOFF SCDESTINATION SCWIDTH SCHEIGHT SCTOPW SCTOPWDS SCTITLEDS SCFDEV SCDS SCDATA 
(* |;;| "Space for native window manager interface to use.") (HANDLE FIXP) (* \; 
"Handle for emulator to store info about display for C code use.") (HANDLE2 FIXP) (* \; 
"Reserved in case HANDLE needs to be 64 bits on the C side.") (NATIVE-INFO POINTER) (* \; 
"POINTER for the private use of the emulator window code") NATIVETYPE (* \; 
"Symbol to tell what kind of native window system we're using.") (* |;;| 
"- - - Functional interface to screen management - - -") WINIMAGEOPS (* \; 
"IMAGEOPS to be used in display streas on this kind of screen") WINFDEV (* \; 
"FDEV for display streams on this screen") CREATEWFN (* \; "Create a window") OPENWFN (* \; 
"Open a window") CLOSEWFN (* \; "Close a window") MOVEWFN (* \; "Move a window") RELMOVEWFN (* \; 
"Move window, relative") SHRINKWFN (* \; "Shrink window to icon") EXPANDWFN (* \; 
"Expand icon to window") SHAPEWFN (* \; "Reshape a window") REDISPLAYFN (* \; 
"Redisplay (part of) a window") GETWINDOWPROPFN (* \; "Get window property value") PUTWINDOWPROPFN (* 
\; "Set window property value") BURYWFN (* \; "Move window behind all others") TOTOPWFN (* \; 
"Move iwindow in front of all others") IMPORTWFN (* \; 
"Take a native window and save its state internally") EXPORTWFN (* \; 
"Take a saved window state and open it on this screen, filling in screen and methods as needed.") 
DESTROYFN (* \; "Destroy this window, for GC finaliszation") SETCURSORFN (* \; 
"Set the cursor for this window.") PROMPTW (* \; "The prompt window for this screen") SHOWGCFN (* \; 
"Show GC indication; called with ON/OFF arg, t=>show gcing status, NIL=>turn off GC indicator.") 
DSPCREATEFN (* \; "Create a displaystream on this screen.") BBTTOWIN (* \; 
"BITBLT from a lisp bitmap to a window") BBTFROMWIN (* \; "BITBLT from a window to a lisp bitmap") 
BBTWINWIN (* \; "BITBLT from a window to another window.") SCCURSOR (* \; 
"CURSOR that's in effect for this screen by default.") SCKEYBOARD (* \; 
"Something about which keyboard we're receiving from.") SCDEPTH (* \; 
"# of bits per pixel on the screen.  THIS WILL REPLACE SCBITSPERPIXEL ASAP.") SCCLOSEDOWN (* \; 
"Close down this screen cleanly, saving window state.") SCCLOSESCREEN (* \; 
"Close down thie screen cleanly, no state saving.") SCREOPEN (* \; "Reopen this screen?") SCCARETFLASH
 (* \; "Function to flash thecaret.") SCGETSCREENPOSITION (* \; "GETSCREENPOSITION") 
SCGETBOXSCREENPOSITION (* \; "GETBOXPOSITION") SCGETSCREENREGION (* \; "GETREGION") SCMOVEPOINTER (* 
\; "\\CURSORPOSITION")) SCONOFF _ (QUOTE OFF) (ACCESSFNS ((SCBITSPERPIXEL (COND ((|fetch| (SCREEN 
SCDESTINATION) |of| DATUM) (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| (|fetch| (SCREEN SCDESTINATION) 
|of| DATUM))) (T 1))) (SCREGION (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (|fetch| (SCREEN SCWIDTH)
 |of| DATUM) HEIGHT _ (|fetch| (SCREEN SCHEIGHT) |of| DATUM))))) (SYSTEM))
(GLOBALVARS WINDOWUSERFORMS ENDOFWINDOWUSERFORMS PROMPTWINDOW)
(PUTPROP (QUOTE WINDOW) (QUOTE IMPORTDATE) (IDATE " 9-Apr-2000 17:36:29"))

(PUTPROPS NNLITATOM MACRO (OPENLAMBDA (X) (AND X (LITATOM X))))
(PUTPROPS \\NULL.OR.FIXP MACRO (OPENLAMBDA (X) (OR (NULL X) (FIXP X))))
(PUTPROPS \\CHECKTYPE MACRO (X (PROG ((VAR (CAR X)) (PRED (CADR X))) (|if| (AND (LISTP PRED) (MEMB (
CAR PRED) (QUOTE (QUOTE FUNCTION)))) |then| (SETQ PRED (LIST (CADR PRED) VAR))) (RETURN (SUBPAIR (
QUOTE (MSG VAR PRED)) (LIST (CONCAT "
 is not a suitable value for the variable:  " VAR) VAR PRED) (QUOTE (|until| PRED |do| (SETQ VAR (
ERROR VAR MSG)))))))))
(PUTPROPS CANONICAL.TIMERUNITS MACRO (OPENLAMBDA (X) (* |Checks| |for| |common| |abbreviations| 
|before| |calling| |\\CanonicalizeTimerUnits|) (SELECTQ X ((TICKS MILLISECONDS SECONDS) (* |These| 
|are| |the| |canonical| |forms|) X) (NIL (QUOTE MILLISECONDS)) (|\\CanonicalizeTimerUnits| X))))
(PUTPROPS \\MACRO.EVAL DMACRO (Z (PROG ((X (EXPANDMACRO (CAR Z) T))) (|if| (EQ X (CAR Z)) |then| (
ERROR "No macro property -- \\MACRO.EVAL" X) |else| (RETURN (EVAL X))))))
(DEFOPTIMIZER \\MACRO.MX (FORM) FORM)
(PUTPROP (QUOTE MACROAUX) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:26:31"))

(RPAQQ MASK0WORD1\'S 32767)
(RPAQQ MASK1WORD0\'S 32768)
(RPAQQ MASKWORD1\'S 65535)
(RPAQQ MASKHALFWORD1\'S 255)
(RPAQQ BITSPERHALFWORD 8)
(CONSTANTS MASK0WORD1\'S MASK1WORD0\'S MASKWORD1\'S MASKHALFWORD1\'S BITSPERHALFWORD)
(PUTPROPS EQZEROP MACRO ((X) (EQ 0 X)))
(PUTPROPS \\MOVETOBOX DMACRO (OPENLAMBDA (N D) (SELECTC (NTYPX N) (\\SMALLP (|replace| (FIXP HINUM) 
|of| D |with| 0) (|replace| (FIXP LONUM) |of| D |with| N)) (\\FIXP (|replace| (FIXP HINUM) |of| D 
|with| (|fetch| (FIXP HINUM) |of| N)) (|replace| (FIXP LONUM) |of| D |with| (|fetch| (FIXP LONUM) |of|
 N))) (\\ILLEGAL.ARG N))))
(PUTPROPS .XUNBOX. MACRO ((X HX LX) (|until| (SETQ LX (SELECTC (NTYPX X) (\\SMALLP (COND ((IGEQ X 0) (
SETQ HX 0) X) (T (SETQ HX MASKWORD1\'S) (\\LOLOC X)))) (\\FIXP (SETQ HX (|fetch| (FIXP HINUM) |of| X))
 (|fetch| (FIXP LONUM) |of| X)) NIL)) |do| (SETQ X (LISPERROR "ILLEGAL ARG" X T)))))
(PUTPROPS .XLLSH. MACRO ((HI LO N) (|if| (IGEQ N BITSPERWORD) |then| (* \; 
"Jump 16 bits in a single bound!") (SETQ HI LO) (SETQ LO 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) (
|if| (IGEQ N BITSPERHALFWORD) |then| (* \; "Jump 8 bits in a single bound!") (SETQ HI (LOGOR (
.LOHALFWORDHI. HI) (.HIHALFWORDLO. LO))) (SETQ LO (.LOHALFWORDHI. LO)) (SETQ N (IDIFFERENCE N 
BITSPERHALFWORD))) (|if| (IGEQ N 4) |then| (* \; "Jump 4 bits in a single bound!") (SETQ HI (LOGOR (
LRSH LO (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LLSH (LOGAND HI (CONSTANT (MASK.1\'S 0 (IDIFFERENCE 
BITSPERWORD 4)))) 4))) (SETQ LO (LLSH (LOGAND LO (CONSTANT (MASK.1\'S 0 (IDIFFERENCE BITSPERWORD 4))))
 4)) (SETQ N (IDIFFERENCE N 4))) (* \; 
"MASK0WORD1'S should be same as (SUB1 (LSH 1 (SUB1 BITSPERWORD)))") (FRPTQ N (SETQ HI (LLSH (LOGAND HI
 MASK0WORD1\'S) 1)) (SETQ LO (LLSH (|if| (IGEQ LO MASK1WORD0\'S) |then| (|add| HI 1) (LOGAND LO 
MASK0WORD1\'S) |else| LO) 1)))))
(PUTPROPS .XLLSH1. MACRO ((HI LO) (SETQ HI (LLSH (LOGAND HI MASK0WORD1\'S) 1)) (SETQ LO (LSH (COND ((
IGEQ LO MASK1WORD0\'S) (SETQ HI (LOGOR HI 1)) (LOGAND LO MASK0WORD1\'S)) (T LO)) 1))))
(PUTPROPS .XLRSH. MACRO ((HI LO N) (|if| (IGEQ N BITSPERWORD) |then| (* \; 
"Jump 10 bits in a single bound!") (SETQ LO HI) (SETQ HI 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) (
|if| (IGEQ N BITSPERHALFWORD) |then| (* \; "Jump 8 bits in a single bound!") (SETQ LO (LOGOR (
.HIHALFWORDLO. LO) (.LOHALFWORDHI. HI))) (SETQ HI (.HIHALFWORDLO. HI)) (SETQ N (IDIFFERENCE N 
BITSPERHALFWORD))) (|if| (IGEQ N 4) |then| (* \; "Jump 4 bits in a single bound!") (SETQ LO (LOGOR (
LLSH (LOGAND HI (CONSTANT (MASK.1\'S 0 4))) (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LRSH LO 4))) (
SETQ HI (LRSH HI 4)) (SETQ N (IDIFFERENCE N 4))) (* \; "MASK1WORD0'S should be same as \\SIGNBIT") (
FRPTQ N (SETQ LO (|if| (ODDP HI) |then| (LOGOR (LRSH LO 1) MASK1WORD0\'S) |else| (LRSH LO 1))) (SETQ 
HI (LRSH HI 1)))))
(PUTPROPS .ADD.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* \; "Ignores carry out of high-order word") (
SETQ HX (.SUMSMALLMOD. HX HY)) (SETQ LX (.SUMSMALLMOD. LX LY (SETQ HX (|if| (EQ HX MAX.SMALL.INTEGER) 
|then| 0 |else| (ADD1 HX)))))))
(PUTPROPS .SUB.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* \; "Ignores carry out of high-order word") (
SETQ HX (.DIFFERENCESMALLMOD. HX HY)) (SETQ LX (.DIFFERENCESMALLMOD. LX LY (SETQ HX (|if| (EQ HX 0) 
|then| MAX.SMALL.INTEGER |else| (SUB1 HX)))))))
(PUTPROPS .32BITMUL. MACRO ((HR LR X Y) (PROG (HX LX HY LY) (|if| (ILESSP X Y) |then| (|swap| X Y)) (*
 \; "Y is the lesser of the two now") (.XUNBOX. X HX LX) (.XUNBOX. Y HY LY) LP (|if| (ODDP LY) |then| 
(.ADD.2WORD.INTEGERS. HR LR HX LX)) (|if| (EQ HY 0) |then| (SETQ LY (LRSH LY 1)) (|if| (EQ LY 0) 
|then| (RETURN)) |else| (.LRSH1. HY LY)) (* \; 
"Trim off highest bits, so that left-shifting doesn't generate FIXPs") (SETQ HX (LOGAND HX 
MASK0WORD1\'S)) (.LLSH1. HX LX) (GO LP))))
(PUTPROPS .SUMSMALLMOD. MACRO ((X Y OVERFLOWFORM) ((LAMBDA (|\\SumSmallModVar|) (DECLARE (LOCALVARS 
|\\SumSmallModVar|)) (IF (ILEQ X |\\SumSmallModVar|) THEN (IPLUS X Y) ELSE OVERFLOWFORM (IDIFFERENCE X
 (ADD1 |\\SumSmallModVar|)))) (IDIFFERENCE MAX.SMALL.INTEGER Y))))
(PUTPROPS .DIFFERENCESMALLMOD. MACRO ((X Y BORROWFORM) (IF (NOT (IGREATERP Y X)) THEN (IDIFFERENCE X Y
) ELSE BORROWFORM (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (IDIFFERENCE Y X))))))
(PUTPROPS \\GETBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (|\\Byte|) (DECLARE (LOCALVARS 
|\\Byte|)) (|if| (ODDP OFFST) |then| (LOGAND |\\Byte| (CONSTANT (MASK.1\'S 0 BITSPERNIBBLE))) |else| (
LRSH |\\Byte| BITSPERNIBBLE))) (\\GETBASEBYTE BASE (FOLDLO OFFST NIBBLESPERBYTE)))))
(PUTPROPS \\PUTBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (|\\ByteNo|) (DECLARE (
LOCALVARS |\\ByteNo|)) ((LAMBDA (|\\Byte|) (DECLARE (LOCALVARS |\\Byte|)) (\\PUTBASEBYTE BASE 
|\\ByteNo| (|if| (ODDP OFFST) |then| (LOGOR (LOGAND |\\Byte| (CONSTANT (MASK.1\'S BITSPERNIBBLE 
BITSPERNIBBLE))) VAL) |else| (LOGOR (LOGAND |\\Byte| (CONSTANT (MASK.1\'S 0 BITSPERNIBBLE))) (LLSH VAL
 BITSPERNIBBLE))))) (\\GETBASEBYTE BASE |\\ByteNo|))) (FOLDLO OFFST NIBBLESPERBYTE))))
(PUTPROPS \\GETBASEBIT DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (|\\ByteNo| |\\BitMask|) (DECLARE (
LOCALVARS |\\ByteNo| |\\BitMask|)) (|if| (EQ 0 (LOGAND |\\BitMask| (\\GETBASEBYTE BASE |\\ByteNo|))) 
|then| 0 |else| 1)) (FOLDLO OFFST BITSPERBYTE) (MASK.1\'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) (
IMOD OFFST BITSPERBYTE)) 1))))
(PUTPROPS \\PUTBASEBIT DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (|\\ByteNo| |\\BitMask| |\\Byte|) 
(DECLARE (LOCALVARS |\\ByteNo| |\\BitMask| |\\Byte|)) (SETQ |\\Byte| (\\GETBASEBYTE BASE |\\ByteNo|)) 
(|if| (|if| (EQ 0 (LOGAND |\\BitMask| |\\Byte|)) |then| (NOT (EQ 0 VAL)) |else| (EQ 0 VAL)) |then| (
\\PUTBASEBYTE BASE |\\ByteNo| (LOGXOR |\\BitMask| |\\Byte|))) VAL) (FOLDLO OFFST BITSPERBYTE) (
MASK.1\'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) (IMOD OFFST BITSPERBYTE)) 1))))
(PUTPROP (QUOTE ADDARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 11:46:37"))

(RPAQQ \\MAXFILEPAGE 65534)
(CONSTANTS \\MAXFILEPAGE)
(PUTPROP (QUOTE LLFAULT) (QUOTE IMPORTDATE) (IDATE " 2-Jan-1993 12:26:58"))

(PUTPROPS \\UPDATETIMERS MACRO (NIL (* * |Moves| |excess| |time| |from| |the| |processor| |clock| |to|
 |our| |software| |clocks.| |Needs| |to| |be| |run| |often,| |uninterruptably,| |preferably| |from| 
|the| |vertical| |retrace| |interrupt|) (* |Get| |processor| |clock|) (PROG ((EXCESS (\\BOXIDIFFERENCE
 (\\RCLK (LOCF (|fetch| RCLKTEMP0 |of| \\MISCSTATS))) (LOCF (|fetch| BASECLOCK |of| \\MISCSTATS))))) (
RETURN (COND ((OR (IGEQ EXCESS \\RCLKSECOND) (ILESSP EXCESS 0)) (* |More| |than| |one| |second| |has| 
|elapsed| |since| |we| |updated| |clocks|) (\\BOXIPLUS (LOCF (|fetch| BASECLOCK |of| \\MISCSTATS)) 
\\RCLKSECOND) (* |Increment| |base| |by| |one| |second|) (\\BOXIPLUS (LOCF (|fetch| MILLISECONDSCLOCK 
|of| \\MISCSTATS)) 1000) (* |Increment| |clocks| |by| 1 |second|) (\\BOXIPLUS (LOCF (|fetch| 
SECONDSCLOCK |of| \\MISCSTATS)) 1) T))))))
(RPAQQ \\RTCSECONDS 378)
(RPAQQ \\RTCMILLISECONDS 380)
(RPAQQ \\RTCBASE 382)
(RPAQQ \\OFFSET.SECONDS 0)
(RPAQQ \\OFFSET.MILLISECONDS 2)
(RPAQQ \\OFFSET.BASE 4)
(RPAQQ \\ALTO.RCLKSECOND 1680000)
(RPAQQ \\ALTO.RCLKMILLISECOND 1680)
(RPAQQ \\DLION.RCLKMILLISECOND 35)
(RPAQQ \\DLION.RCLKSECOND 34746)
(RPAQQ \\DOVE.RCLKMILLISECOND 63)
(RPAQQ \\DOVE.RCLKSECOND 62500)
(CONSTANTS (\\RTCSECONDS 378) (\\RTCMILLISECONDS 380) (\\RTCBASE 382) (\\OFFSET.SECONDS 0) (
\\OFFSET.MILLISECONDS 2) (\\OFFSET.BASE 4) (\\ALTO.RCLKSECOND 1680000) (\\ALTO.RCLKMILLISECOND 1680) (
\\DLION.RCLKMILLISECOND 35) (\\DLION.RCLKSECOND 34746) (\\DOVE.RCLKMILLISECOND 63) (\\DOVE.RCLKSECOND 
62500))
(PUTPROPS ALTO.TO.LISP.DATE MACRO ((DATE) (LOGXOR DATE -2147483648)))
(PUTPROPS LISP.TO.ALTO.DATE MACRO ((DATE) (LOGXOR DATE -2147483648)))
(PUTPROP (QUOTE LLTIMER) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:13:11"))

(DATATYPE SYSQUEUE ((NIL BYTE) (SYSQUEUEHEAD POINTER) (NIL BYTE) (SYSQUEUETAIL POINTER)))
(BLOCKRECORD QABLEITEM ((NIL BITS 4) (QLINK POINTER) (* \; 
"Link to next thing in queue always in first pointer of datum, independent of what the datum is")) (
BLOCKRECORD QABLEITEM ((NIL BITS 4) (LINK POINTER) (* \; "Let's also be able to call it a LINK"))))
(PUTPROPS \\QUEUEHEAD MACRO ((Q) (|fetch| (SYSQUEUE SYSQUEUEHEAD) |of| Q)))
(PUTPROPS \\DETCONC MACRO (OPENLAMBDA (TQ) (PROG1 (\\PEEKTCONC TQ) (|if| (NULL (CAR (RPLACA TQ (CDAR 
TQ)))) |then| (RPLACD TQ)))))
(PUTPROPS \\ENTCONC MACRO (= . TCONC))
(PUTPROPS \\PEEKTCONC MACRO (= . CAAR))
(DATATYPE ETHERPACKET ((NIL BYTE) (EPLINK POINTER) (* \; "For queue maintenence") (EPFLAGS BYTE) (* \;
 "optional flags for some applications") (EPUSERFIELD POINTER) (* \; 
"Arbitrary pointer for applications") (NIL BYTE) (EPPLIST POINTER) (* \; 
"Extra field for use as an A-list for properties") (EPTRANSMITTING FLAG) (* \; 
"True while packet is being transmitted and hence cannot be reused") (EPRECEIVING FLAG) (* \; 
"True when a packet has been seen at the head of the network's input queue at least once") (NIL BITS 6
) (EPREQUEUE POINTER) (* \; "Where to requeue this packet after transmission") (NIL BYTE) (EPSOCKET 
POINTER) (NIL BYTE) (EPNETWORK POINTER) (EPTYPE WORD) (* \; 
"Type of packet to be encapsulated (PUP or XIP or 10TO3)") (NIL WORD) (EPTIMESTAMP FIXP) (* \; 
"Gets RCLK value when transmitted/received") (EPREQUEUEFN POINTER) (* \; "FN to perform requeueing") (
NIL 4 WORD) (* \; "Space for expansion") (* \; 
"Note: This next field wants to be quad+2 aligned so that the 10mb packet is quad+3 aligned") (
EPENCAPSULATION 8 WORD) (* \; "10mb encapsulation, or 3mb encapsulation with padding") (EPBODY 289 
WORD) (* \; "Body of packet, header up to 16 words plus data up to 546 bytes")))
(ACCESSFNS ETHERAUX ((AUXPTR (CDR (ASSOC (QUOTE AUXPTR) (|fetch| EPPLIST |of| DATUM))) (\\EP.PUT.AUX 
DATUM (QUOTE AUXPTR) NEWVALUE)) (AUXWORD (OR (CDR (ASSOC (QUOTE AUXWORD) (|fetch| EPPLIST |of| DATUM))
) 0) (\\EP.PUT.AUX DATUM (QUOTE AUXWORD) NEWVALUE)) (AUXBYTE (OR (CDR (ASSOC (QUOTE AUXBYTE) (|fetch| 
EPPLIST |of| DATUM))) 0) (\\EP.PUT.AUX DATUM (QUOTE AUXBYTE) NEWVALUE))))
(RPAQQ \\EPT.PUP 512)
(RPAQQ \\EPT.XIP 1536)
(RPAQQ \\3MBTYPE.XIP 1536)
(RPAQQ \\10MBTYPE.XIP 1536)
(RPAQQ \\EPT.10TO3 1537)
(RPAQQ \\3MBTYPE.10TO3 1537)
(RPAQQ \\EPT.UNKNOWN 255)
(CONSTANTS \\EPT.PUP \\EPT.XIP \\3MBTYPE.XIP \\10MBTYPE.XIP \\EPT.10TO3 \\3MBTYPE.10TO3 \\EPT.UNKNOWN)
(RPAQQ \\NULLCHECKSUM 65535)
(CONSTANTS (\\NULLCHECKSUM 65535))
(DATATYPE NDB ((NETTYPE BYTE) (* \; "10 or 3 for now") (NDBNEXT POINTER) (* \; "Link to next NDB") (
NDBPUPNET# BYTE) (* \; 
"Pup number of this net.  May be different from NS net number, though not in Xerox world") (NDBNSNET# 
POINTER) (* \; "Can be 32-bits, so might as well leave its box around") (NDBTASK# BYTE) (* \; 
"Task # of this network") (NDBBROADCASTP POINTER) (* \; 
"Function that returns true if packet is of broadcast type") (NDBPUPHOST# BYTE) (* \; 
"My pup address on this net.  NS address is global to all nets, so not needed here") (NDBTRANSMITTER 
POINTER) (* \; "(NDB PACKET) -- fn to send a raw packet on this net.  returns NIL on failure") (NIL 
BYTE) (NDBENCAPSULATOR POINTER) (* \; 
"(NDB PACKET HOST LENGTH TYPE) -- fn to encapsulate and send a higher-level packet on this net ") (
NDBCSB POINTER) (* \; "Pointer to CSB for this network") (NDBIQLENGTH BYTE) (NDBIQ POINTER) (* \; 
"Queue of empty packets for receiver") (NDBTQ POINTER) (* \; "Queue of packets to transmit") (
NDBTRANSLATIONS POINTER) (* \; "Cache of translations, 3:10 or 10:3 according to network") (
NDBETHERFLUSHER POINTER) (* \; "Turns off this ether.  Args NDB") (NDBWATCHER POINTER) (NDBCANHEARSELF
 POINTER) (* \; "True if receiver can hear packets sent by transmitter") (NDBIPNET# POINTER) (
NDBIPHOST# POINTER) (NDBPUPTYPE WORD) (* \; "The packet encapsulation of PUP on this net") (NIL WORD) 
(NIL POINTER) (* \; "Spares")))
(RECORD ROUTING (RTNET# RTHOPCOUNT RTGATEWAY# RTNDB RTTIMER RTRECENT))
(PUTPROPS \\SERIALNUMBER MACRO (NIL (|fetch| (IFPAGE |SerialNumber|) |of| |\\InterfacePage|)))
(PUTPROPS \\DEVICE.INPUT DOPVAL (1 MISC1 1))
(PUTPROPS \\DEVICE.OUTPUT DOPVAL (2 MISC2 2))
(PUTPROPS \\D0.STARTIO DOPVAL (1 MISC1 0))
(PUTPROP (QUOTE LLETHER) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 10:49:30"))

(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR) BRUSHSHAPE _ (QUOTE ROUND) BRUSHSIZE _ 1)
(PUTPROPS IMAGEOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) (
QUOTE QUOTE)) (LIST (QUOTE |fetch|) (LIST (QUOTE IMAGEOPS) (CADAR ARGS)) (QUOTE |of|) (LIST (QUOTE 
|fetch|) (QUOTE (STREAM IMAGEOPS)) (QUOTE |of|) (CADR ARGS)))) (T (HELP "IMAGEOP - OPNAME not quoted:"
 ARGS))) (CDDR ARGS)))))
(DATATYPE IMAGEOPS (IMAGETYPE IMCLOSEFN IMXPOSITION IMYPOSITION IMFONT IMLEFTMARGIN IMRIGHTMARGIN 
IMLINEFEED IMDRAWLINE IMDRAWCURVE IMDRAWCIRCLE IMDRAWELLIPSE IMFILLCIRCLE IMBLTSHADE IMBITBLT 
IMNEWPAGE IMMOVETO IMSCALE IMTERPRI IMTOPMARGIN IMBOTTOMMARGIN IMSPACEFACTOR IMFONTCREATE IMOPERATION 
IMCOLOR IMSTRINGWIDTH IMCHARWIDTH IMCHARWIDTHY IMBACKCOLOR IMBITMAPSIZE IMCLIPPINGREGION IMRESET 
IMDRAWPOLYGON IMFILLPOLYGON IMSCALEDBITBLT IMWRITEPIXEL IMCHARSET IMROTATE IMDRAWARC IMTRANSLATE 
IMSCALE2 IMPUSHSTATE IMPOPSTATE IMDEFAULTSTATE IMDRAWPOINT IMBLTCHAR IMXOFFSET IMYOFFSET) IMCLOSEFN _ 
(FUNCTION NILL) IMTERPRI _ (FUNCTION (LAMBDA (STREAM) (\\OUTCHAR STREAM (CHARCODE EOL)))) IMNEWPAGE _ 
(FUNCTION (LAMBDA (STREAM) (\\OUTCHAR STREAM (CHARCODE ^L)))) IMOPERATION _ (FUNCTION NILL) IMCOLOR _ 
(FUNCTION NILL) IMCLIPPINGREGION _ (FUNCTION NILL) IMRESET _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION 
NILL) IMSTRINGWIDTH _ (FUNCTION (LAMBDA (STREAM STR RDTBL) (STRINGWIDTH STR (DSPFONT NIL STREAM) RDTBL
 RDTBL))) IMCHARWIDTH _ (FUNCTION (LAMBDA (STREAM CHARCODE) (CHARWIDTH CHARCODE (DSPFONT NIL STREAM)))
) IMMOVETO _ (FUNCTION (LAMBDA (STREAM X Y) (IMAGEOP (QUOTE IMXPOSITION) STREAM STREAM X) (IMAGEOP (
QUOTE IMYPOSITION) STREAM STREAM Y))) IMBITMAPSIZE _ (FUNCTION (LAMBDA (STREAM BITMAP DIMENSION) (
SELECTQ DIMENSION (WIDTH (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP))) (HEIGHT (TIMES (DSPSCALE 
NIL STREAM) (BITMAPHEIGHT BITMAP))) (NIL (CONS (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP)) (
TIMES (DSPSCALE NIL STREAM) (BITMAPHEIGHT BITMAP)))) (\\ILLEGAL.ARG DIMENSION)))) IMWRITEPIXEL _ (
FUNCTION NILL) IMCHARSET _ (FUNCTION NILL) IMXPOSITION _ (FUNCTION NILL) IMYPOSITION _ (FUNCTION NILL)
 IMFONT _ (FUNCTION NILL) IMLEFTMARGIN _ (FUNCTION NILL) IMRIGHTMARGIN _ (FUNCTION NILL) IMLINEFEED _ 
(FUNCTION NILL) IMDRAWLINE _ (FUNCTION NILL) IMDRAWCURVE _ (FUNCTION NILL) IMDRAWCIRCLE _ (FUNCTION 
NILL) IMDRAWELLIPSE _ (FUNCTION NILL) IMFILLCIRCLE _ (FUNCTION NILL) IMBLTSHADE _ (FUNCTION NILL) 
IMBITBLT _ (FUNCTION NILL) IMSCALE _ (FUNCTION NILL) IMTOPMARGIN _ (FUNCTION NILL) IMBOTTOMMARGIN _ (
FUNCTION NILL) IMSPACEFACTOR _ (FUNCTION NILL) IMFONTCREATE _ (FUNCTION NILL) IMCHARWIDTHY _ (FUNCTION
 NILL) IMDRAWPOLYGON _ (FUNCTION \\DRAWPOLYGON.GENERIC) IMDRAWPOINT _ (FUNCTION \\DRAWPOINT.GENERIC) 
IMFILLPOLYGON _ (FUNCTION NILL) IMSCALEDBITBLT _ (FUNCTION NILL) IMROTATE _ (FUNCTION NILL) IMDRAWARC 
_ (FUNCTION NILL) IMTRANSLATE _ (FUNCTION NILL) IMPUSHSTATE _ (FUNCTION NILL) IMPOPSTATE _ (FUNCTION 
NILL) IMSCALE2 _ (FUNCTION NILL) IMDEFAULTSTATE _ (FUNCTION NILL) IMBLTCHAR _ (FUNCTION \\MEDW.BLTCHAR
) IMXOFFSET _ (FUNCTION \\MEDW.XOFFSET) IMYOFFSET _ (FUNCTION \\MEDW.YOFFSET))
(GLOBALVARS \\NOIMAGEOPS)
(PUTPROP (QUOTE IMAGEIO) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:33:59"))

(DATATYPE PROCESS ((PROCFX0 WORD) (* \; "= \\STACKHI to make this look like a STACKP") (PROCFX WORD) (
* \; "Stack pointer to this context when it is asleep") (PROCSTATUS BYTE) (* \; "Running or waiting") 
(PROCNAME POINTER) (* \; "Name for convenience in type-in reference") (PROCPRIORITY BYTE) (* \; 
"Priority level, 0-4.  Not currently used.") (PROCQUEUE POINTER) (* \; 
"Queue of processes at the same priority") (NIL BYTE) (NEXTPROCHANDLE POINTER) (* \; 
"Pointer to next one") (PROCTIMERSET FLAG) (* \; "True if PROCWAKEUPTIMER has an interesting value") (
PROCBEINGDELETED FLAG) (* \; "True if proc was deleted, but hasn't been removed from \\PROCESSES yet")
 (PROCDELETED FLAG) (PROCSYSTEMP FLAG) (PROCNEVERSTARTED FLAG) (NIL FLAG) (NIL FLAG) (NIL FLAG) (
PROCWAKEUPTIMER POINTER) (* \; "a largep recording the time this proc last went to sleep") (
PROCTIMERLINK POINTER) (* \; "For linking proc in timer queue") (PROCTIMERBOX POINTER) (* \; 
"Scratch box to use for PROCWAKEUPTIMER when user does not give one explicitly") (WAKEREASON POINTER) 
(* \; "Reason process is being run.  From WAKE.PROCESS or timer or event wakeup;  T from simple BLOCK"
) (PROCEVENTORLOCK POINTER) (* \; "EVENT or MONITOR lock that this proc is waiting for") (PROCFORM 
POINTER) (* \; "Form to EVAL to start it going") (RESTARTABLE POINTER) (* \; 
"T = autorestart on error, HARDRESET = restart only on hard reset, NIL = never restart") (PROCWINDOW 
POINTER) (* \; "Window this process lives in, if any") (PROCFINISHED POINTER) (* \; 
"True if proc finished.  Value is indication of how: NORMAL, DELETED, ERROR") (PROCRESULT POINTER) (* 
\; "Value it returned if it finished normally") (PROCFINISHEVENT POINTER) (* \; 
"Optional EVENT to be notified when proc finishes") (PROCMAILBOX POINTER) (* \; "Message queue") (
PROCDRIBBLEOUTPUT POINTER) (* \; "Binding for *DRIBBLE-OUTPUT* in this process") (PROCINFOHOOK POINTER
) (* \; "Optional user fn that displays info about process") (PROCTYPEAHEAD POINTER) (* \; 
"Buffer of typeahead destined for this proc") (PROCREMOTEINFO POINTER) (* \; "For Enterprise") (
PROCUSERDATA POINTER) (* \; "For PROCESSPROP") (PROCEVENTLINK POINTER) (* \; 
"Used to maintain EVENT queues") (PROCAFTEREXIT POINTER) (* \; 
"What to do with this process when coming back from a LOGOUT, etc") (PROCBEFOREEXIT POINTER) (* \; 
"If DON'T, can't logout") (PROCOWNEDLOCKS POINTER) (* \; "Pointer to first lock I currently own") (
PROCEVAPPLYRESULT POINTER) (* \; "For PROCESS.EVAL and PROCESS.APPLY when WAITFORRESULT is true") (
PROCTTYENTRYFN POINTER) (* \; "Is applied to a process when it becomes the tty process") (
PROCTTYEXITFN POINTER) (* \; "Is applied to a process when it ceases to be the tty process") (
PROCHARDRESETINFO POINTER) (* \; "HARDRESET stores info about unwind-protect cleanups here") (
PROCRESTARTFORM POINTER) (* \; "use this instead of PROCFORM when restarting") (PROCOLDTTYPROC POINTER
) (* \; "Process that had the tty when we got it") (NIL POINTER) (* \; "For expansion")) PROCTIMERBOX 
_ (CREATECELL \\FIXP) PROCFX0 _ \\STACKHI)
(PUTPROPS THIS.PROCESS MACRO (NIL \\RUNNING.PROCESS))
(PUTPROPS TTY.PROCESS MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE \\TTY.PROCESS)))))
(PUTPROPS TTY.PROCESSP MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE (OR (NULL (THIS.PROCESS)
) (EQ (THIS.PROCESS) (TTY.PROCESS))))))))
(GLOBALVARS \\RUNNING.PROCESS \\TTY.PROCESS \\PROC.RESTARTME \\PROC.RESETME \\PROC.ABORTME)
(PUTPROP (QUOTE PROC) (QUOTE IMPORTDATE) (IDATE "17-Jun-1999 21:58:52"))

(PUTPROPS \\BACKCHAR MACRO (OPENLAMBDA (STREAM) (* \; "Backs up over an NS character") (\\BACKNSCHAR 
STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256))))
(PUTPROPS \\BACKNSCHAR MACRO ((ST SHIFTEDCHARSET COUNTERVAR) (COND ((\\XCCSP ST) (\\BACKXCCSCHAR ST 
SHIFTEDCHARSET COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR (
CL:FUNCALL (|ffetch| (STREAM BACKCHARFN) |of| ST) ST T)))) (T (CL:FUNCALL (|ffetch| (STREAM BACKCHARFN
) |of| ST) ST NIL)))))))
(PUTPROPS \\CHECKEOLC MACRO (OPENLAMBDA (CH EOLC STREAM PEEKBINFLG COUNTERVAR) (* |;;| 
"Subtracts number of bytes read from COUNTERVAR, which may be NIL.  In fact, should be NIL if PEEKBINFLG is T."
) (SELCHARQ CH (CR (SELECTC EOLC (CR.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND (PEEKBINFLG (* |;;| 
"T from PEEKC, compile-time constant.  In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts"
) (COND ((EQ (CHARCODE LF) (UNINTERRUPTABLY (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* 
|;;| 
"Read the NS CR.  We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \\NSPEEK that got the CR character.  Since we are going to NS back the CR character, we don't need to update the counter variable"
) (PROG1 (\\PEEKBIN STREAM T) (* |;;| 
"LF must be in next BYTE after NS CR, regardless of coding.  Character-set shifting bytes can't intervene.  Then we back up over the CR that was \\NSINed above."
) (\\BACKNSCHAR STREAM)))) (CHARCODE EOL)) (T (CHARCODE CR)))) ((EQ (CHARCODE LF) (\\PEEKBIN STREAM T)
) (\\BIN STREAM) (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (SUB1 COUNTERVAR))) (CHARCODE EOL)) (T (
CHARCODE CR)))) (CHARCODE CR))) (LF (COND ((EQ EOLC LF.EOLC) (CHARCODE EOL)) (T (CHARCODE LF)))) CH)))
(PUTPROPS \\INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* \; "returns a 16 bit character code") (
\\CHECKEOLC (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (FFETCH EOLCONVENTION 
OF STREAM) STREAM NIL COUNTERVAR)))
(PUTPROPS \\INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* \; "returns a 16 bit character code") (
\\CHECKEOLC (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (|ffetch| 
EOLCONVENTION |of| STREAM) STREAM NIL COUNTERVAR)))
(PUTPROPS \\PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR) (\\CHECKEOLC (\\NSPEEK STREAM (UNFOLD (
ACCESS-CHARSET STREAM) 256) NIL NOERROR) (|ffetch| EOLCONVENTION |of| STREAM) STREAM T)))
(PUTPROPS \\NSIN MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* |;;;| 
"Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here."
) (COND ((\\XCCSP ST) (\\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR
) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (|ffetch| (STREAM INCCODEFN) |of| ST) ST T) (AND NUM 
(SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (|ffetch| (STREAM INCCODEFN) 
|of| ST) ST NIL)))))))
(PUTPROPS \\NSPEEK MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* |;;;| 
"Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here."
) (COND ((\\XCCSP ST) (\\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST) 256) NIL NOERROR)) (T (COND ((QUOTE 
COUNTERVAR) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (|ffetch| (STREAM PEEKCCODEFN) |of| ST) ST 
NOERROR T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (|ffetch| (
STREAM PEEKCCODEFN) |of| ST) ST NOERROR NIL)))))))
(PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET))
(PUTPROPS \\CONV.JIS.TO.XCCS MACRO (OPENLAMBDA (KU TEN) (* |;;;| 
"Some character code is not equivalent between JIS and XCCS.  In such case, we have to convert the character to corresponding XCCS."
) (COND ((\\NOT.EQUIVALENT.TO.XCCS KU) (\\DO.CONV.JIS.TO.XCCS KU TEN)) (T (LOGOR (UNFOLD KU 256) TEN))
)))
(PUTPROPS \\DO.CONV.JIS.TO.XCCS MACRO ((KU TEN) (* |;;;| 
" Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.")
 (COND ((\\INVALID.TENP TEN) *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (SELECTQ KU ((33 34 38) (* \; 
"1, 2 and 6 KU") (LET* ((CONVTABLE (\\EXTARACT.CONV.TABLE KU)) (SET (\\EXTRACT.SET TEN CONVTABLE)) (
CODE (\\EXTRACT.CODE TEN CONVTABLE))) (COND ((NEQ SET 255) (LOGOR (UNFOLD SET 256) CODE)) (T (COND ((
EQ CODE 255) (* \; "Not defined in JIS.") *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (* \; 
"Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.") (COND (
*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 
256) TEN)))))))))) (35 (* \; "3 KU") (* \; 
"Alpha numeric codes are all defined as single byte codes in XCCS.") TEN) (40 (* \; "8 KU") (COND ((< 
0 TEN 33) (COND (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\\EXTRACT.NO.FONT.CODE (
LOGOR KU TEN))))) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (116 (* \; "84 KU") (COND ((< 0 TEN 5) (LOGOR
 29952 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (117 (* \; "85 KU") (COND ((< 0 TEN 28) (LOGOR 
29696 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) *DEFAULT-NOT-CONVERTED-FAT-CODE*)))))
(PUTPROPS \\CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC) (* |;;;| 
"Returns JIS code corresponding to XCCS charcode.  Handle HANKAKU as well as ZENKAKU.  If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so.  Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode."
) (OR (COND ((\\ASCIIP CC) CC) ((\\NOT.EQUIVALENT.TO.JIS CC) (\\DO.CONV.XCCS.TO.JIS CC)) ((
\\CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM) (* \; 
"ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.") (\\CONV.ZENKAKU.KANA CC)) (
T CC)) CC)))
(PUTPROPS \\DO.CONV.XCCS.TO.JIS MACRO ((CC) (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*)))
(PUTPROPS \\ASCIIP MACRO (OPENLAMBDA (CC) (AND (EQ (FOLDLO CC 256) 0) (< (LOGAND CC 255) 128))))
(PUTPROPS \\NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC) (OR (EQ (FOLDLO CC 256) 0) (EQ (FOLDLO CC 256
) 33) (EQ (FOLDLO CC 256) 34) (EQ (FOLDLO CC 256) 38) (EQ (FOLDLO CC 256) 40) (EQ (FOLDLO CC 256) 239)
 (EQ (FOLDLO CC 256) 241))))
(PUTPROPS \\CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM) (STREAMPROP OUTSTREAM :HTOZP)))
(PUTPROPS \\CONV.ZENKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*)))
(PUTPROPS \\XCCSIN MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* |;;;| 
"returns a 16 bit character code.  SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes.  COUNTERVAR if non-NIL is decremented by number of bytes read.  Doesn't do EOL conversion -- \\INCHAR and \\INCCODE do that."
) (LET ((CHAR (\\BIN STREAM)) SCSET) (COND ((EQ CHAR NSCHARSETSHIFT) (* \; "Shifting character sets") 
(ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\\BIN STREAM))) (AND (QUOTE 
COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* \; 
"2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE 
COUNTERVAR 3))) (EQ 0 (\\BIN STREAM))) \\NORUNCODE) (T (\\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ 
CHAR (\\BIN STREAM)) (SETQ SCSET (COND ((QUOTE SHIFTEDCSETVAR) (* \; "CHARSETVAR=NIL means don't set")
 (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256))))) (T (SETQ SCSET SHIFTEDCSET))) (
COND ((EQ SCSET (UNFOLD \\NORUNCODE 256)) (* \; 
"just read two bytes and combine them to a 16 bit value") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (
IDIFFERENCE COUNTERVAR 2))) (LOGOR (UNFOLD CHAR 256) (\\BIN STREAM))) (CHAR (AND (QUOTE COUNTERVAR) (
SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 1))) (AND CHAR (LOGOR SCSET CHAR)))))))
(PUTPROPS \\XCCSPEEK MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* |;;| 
"Returns a 16 bit character code.  Doesn't do EOL conversion--\\INCHAR does that.  May actually read the character-set shift, storing the result in the stream.  COUNTERVAR, if given, is updated to reflect any such bytes that are actually read"
) (PROG ((CHAR (\\PEEKBIN STREAM NOERROR)) SCSET) (COND ((NULL CHAR) (RETURN NIL)) ((EQ CHAR 
NSCHARSETSHIFT) (* \; "CHARSETVAR=NIL means don't set") (\\BIN STREAM) (* \; 
"Consume the char shift byte") (ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ 
CHAR (\\BIN STREAM))) (* \; 
"Note: no eof error check on this \\BIN -- an eof in the middle of a charset shift is an error") (AND 
(QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* \; 
"2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE 
COUNTERVAR 3))) (EQ 0 (\\BIN STREAM))) \\NORUNCODE) (T (\\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ 
SCSET (COND ((QUOTE SHIFTEDCSETVAR) (* \; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (
UNFOLD SCSET 256))) (T (UNFOLD SCSET 256)))) (COND ((NULL (SETQ CHAR (\\PEEKBIN STREAM NOERROR))) (
RETURN NIL)))) (T (SETQ SCSET SHIFTEDCSET))) (RETURN (COND ((EQ SCSET (UNFOLD \\NORUNCODE 256)) (* 
|;;| 
"just peek two bytes and combine them to a 16 bit value.  Again, is an error if we hit eof in mid-character"
) (\\BIN STREAM) (PROG1 (LOGOR (UNFOLD CHAR 256) (\\PEEKBIN STREAM NOERROR)) (\\BACKFILEPTR STREAM))) 
(T (LOGOR SHIFTEDCSET CHAR)))))))
(PUTPROPS \\BACKXCCSCHAR MACRO ((STREAM SHIFTEDCHARSET COUNTERVAR) (AND (\\BACKFILEPTR STREAM) (COND (
(COND (SHIFTEDCHARSET (EQ SHIFTEDCHARSET (UNFOLD \\NORUNCODE 256))) (T (EQ \\NORUNCODE (ACCESS-CHARSET
 STREAM)))) (COND ((\\BACKFILEPTR STREAM) (AND (QUOTE COUNTERVAR) (|add| COUNTERVAR 2)) T) ((QUOTE 
COUNTERVAR) (|add| COUNTERVAR 1)))) ((QUOTE COUNTERVAR) (|add| COUNTERVAR 1))))))
(PUTPROPS \\XCCSP MACRO (OPENLAMBDA (ST) (NOT (|ffetch| (STREAM NOTXCCS) |of| (\\DTEST ST (QUOTE 
STREAM))))))
(PUTPROPS \\EXTRACT.NO.FONT.CODE MACRO ((JISCODE) (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE*
))))
(PUTPROPS \\EXTARACT.CONV.TABLE MACRO ((KU) (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*))))
(PUTPROPS \\NOT.EQUIVALENT.TO.XCCS MACRO ((KU) (* |;;;| 
" The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU.  Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here."
) (OR (EQ KU 33) (EQ KU 34) (EQ KU 35) (EQ KU 38) (EQ KU 40) (EQ KU 116) (EQ KU 117))))
(PUTPROPS \\EXTRACT.SET MACRO ((TEN TABLE) (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32) 2) 1))
))
(PUTPROPS \\EXTRACT.CODE MACRO ((TEN TABLE) (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32) 2))))
(PUTPROPS \\CHNAGE.KI.MODE MACRO (OPENLAMBDA (ST INPUTFLG ENTERP) (* |;;;| 
"INPUTFLG is true if \\CHNAGE.KI.MODE is called in the context in which ST is an input stream.") (COND
 (INPUTFLG (COND (ENTERP (|freplace| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| T)) (
T (|freplace| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| NIL)))) (T (COND (ENTERP (
|freplace| (STREAM OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| T)) (T (|freplace| (STREAM 
OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| NIL)))))))
(PUTPROPS \\KIMODEP MACRO (OPENLAMBDA (ST INPUTFLG) (* |;;;| 
"INPUTFLG is true if \\KIMODEP is called in the context in which ST is an input stream.") (COND (
INPUTFLG (|ffetch| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)))) (T (|ffetch| (STREAM 
OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)))))))
(PUTPROPS \\HANKAKUP MACRO ((CHAR) (< 160 CHAR 224)))
(PUTPROPS \\KANJIP MACRO ((CHAR) (< 12158 CHAR 29733)))
(PUTPROPS \\NOTGAIJIP MACRO ((CHAR) (OR (< 8480 CHAR 10305) (< 12158 CHAR 29733))))
(PUTPROPS \\INVALID.TENP MACRO (OPENLAMBDA (TEN) (OR (< TEN 33) (< 126 TEN))))
(PUTPROPS \\CONV.HANKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*)))
(PUTPROPS \\OUTKI MACRO ((STREAM) (\\BOUT OUTSTREAM (CHARCODE ESC)) (\\BOUT OUTSTREAM (CHARCODE $)) (
\\BOUT OUTSTREAM (CHARCODE B))))
(PUTPROPS \\OUTKO MACRO ((STREAM) (\\BOUT OUTSTREAM (CHARCODE ESC)) (\\BOUT OUTSTREAM (CHARCODE \()) (
\\BOUT OUTSTREAM (CHARCODE J))))
(PUTPROPS \\CONV.SJIS.TO.JIS MACRO (OPENLAMBDA (HI LO) (* |;;;| 
"Convert Shift-JIS to JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively."
) (SETQ CH1 (IDIFFERENCE HI (COND ((> HI 159) 177) (T 113)))) (SETQ CH1 (IPLUS (UNFOLD CH1 2) 1)) (
SETQ CH2 (COND ((> LO 158) (PROG1 (IDIFFERENCE LO 126) (SETQ CH1 (IPLUS CH1 1)))) (T (IDIFFERENCE LO (
COND ((> LO 126) (IPLUS 31 1)) (T 31))))))))
(PUTPROPS \\CONV.JIS.TO.SJIS MACRO (OPENLAMBDA (HI LO) (* |;;;| 
"Convert JIS to Shift-JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively."
) (SETQ CH2 (COND ((ODDP HI) (SETQ CH2 (IPLUS LO 31)) (COND ((>= CH2 127) (IPLUS CH2 1)) (T CH2))) (T 
(IPLUS LO 126)))) (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33) 2) 129)) (AND (> CH1 159) (SETQ CH1 (
IPLUS CH1 64)))))
(PUTPROPS \\SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR) (OR (< 127 CHAR 160) (< 223 CHAR 256))))
(PUTPROPS \\EUC.KANJI.FIRST.BYTEP MACRO ((CHAR) (< 160 CHAR 255)))
(PUTPROPS \\GAIJIP MACRO ((CHAR) (EQ CHAR 143)))
(PUTPROPS \\EUC.HANKAKUP MACRO ((CHAR) (EQ CHAR 142)))
(PUTPROP (QUOTE LLREAD) (QUOTE IMPORTDATE) (IDATE " 4-Aug-1993 14:43:07"))

(PUTPROPS EMPASSWORDLOC DMACRO (LAMBDA NIL (* |lmm| "24-MAR-83 06:46") (|fetch| (IFPAGE |UserPswdAddr|
) |of| |\\InterfacePage|)))
(PUTPROPS \\DECRYPT.PWD.CHAR MACRO ((CHAR) (LOGXOR CHAR 73)))
(PUTPROP (QUOTE PASSWORDS) (QUOTE IMPORTDATE) (IDATE "16-May-1990 21:02:21"))

(RPAQQ MICASPERINCH 2540)
(RPAQQ MICASPERMILLIMETER 100)
(CONSTANTS (MICASPERINCH 2540) (MICASPERMILLIMETER 100))
(PUTPROP (QUOTE INTERPRESS) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 21:56:38"))

(RPAQ MICASPERPT (FQUOTIENT 2540 72))
(RPAQQ IHALFMICASPERPT 17)
(RPAQQ IMICASPERPT 35)
(CONSTANTS (MICASPERPT (FQUOTIENT 2540 72)) (IHALFMICASPERPT 17) (IMICASPERPT 35))
(DEFMACRO \\MICASTOPTS (MICAS) (COND ((NUMBERP MICAS) (QUOTIENT MICAS MICASPERPT)) (T (BQUOTE (
QUOTIENT (\\\, MICAS) MICASPERPT)))))
(PUTPROP (QUOTE HARDCOPY) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 22:15:08"))

(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT)
(PUTPROP (QUOTE CMLARRAY) (QUOTE IMPORTDATE) (IDATE " 6-Jan-1993 12:21:21"))

(RPAQQ \\MISCN-TABLE-LIST ((USER-SUBR 0 \\USER-SUBR-UFN T) (CL:VALUES 1 CL::VALUES-UFN NIL) (CL:SXHASH
 2 CL::SXHASH-UFN NIL) (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL) (STRINGHASHBITS 4 
\\STRINGHASHBITS-UFN NIL) (STRING-EQUAL-HASHBITS 5 \\STRING-EQUAL-HASHBITS-UFN NIL) (CL:VALUES-LIST 6 
CL::VALUES-LIST-UFN NIL) (|LCFetchMethod| 7 |LCFetchMethod| NIL) (|LCFetchMethodOrHelp| 8 NIL NIL) (
|LCFindVarIndex| 9 NIL NIL) (|LCGetIVValue| 10 NIL NIL) (|LCPutIVValue| 11 NIL NIL)))
(RPAQQ \\USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN) (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))
(RPAQQ \\INITSUBRS ((BACKGROUNDSUBR 6) (CHECKBCPLPASSWORD 7) (DISKPARTITION 8) (DSPBOUT 9) (DSPRATE 10
) (GATHERSTATS 11) (GETPACKETBUFFER 12) (LISPFINISH 13) (MOREVMEMFILE 14) (RAID 15) (READRAWPBI 16) (
WRITERAWPBI 17) (SETSCREENCOLOR 18) (SHOWDISPLAY 19) (PUPLEVEL1STATE 20) (WRITESTATS 21) (
CONTEXTSWITCH 22) (COPYSYS0SUBR 23) (WRITEMAP 24) (UFS-GETFILENAME 34) (UFS-DELETEFILE 35) (
UFS-RENAMEFILE 36) (COM-READPAGES 37) (COM-WRITEPAGES 38) (COM-TRUNCATEFILE 39) (UFS-DIRECTORYNAMEP 41
) (COM-GETFREEBLOCK 45) (SETUNIXTIME 48) (GETUNIXTIME 49) (COPYTIMESTATS 50) (UNIX-USERNAME 51) (
UNIX-FULLNAME 52) (UNIX-GETENV 53) (UNIX-GETPARM 54) (CHECK-SUM 55) (ETHER-SUSPEND 56) (ETHER-RESUME 
57) (ETHER-AVAILABLE 58) (ETHER-RESET 59) (ETHER-GET 60) (ETHER-SEND 61) (ETHER-SETFILTER 62) (
ETHER-CHECK 63) (DSPCURSOR 64) (SETMOUSEXY 65) (DSP-VIDEOCOLOR 66) (DSP-SCREENWIDTH 67) (
DSP-SCREENHEIGHT 68) (BITBLTSUB 69) (BLTCHAR 70) (TEDIT.BLTCHAR 71) (BITBLT.BITMAP 72) (
BLTSHADE.BITMAP 73) (RS232C-CMD 74) (RS232C-READ-INIT 75) (RS232C-WRITE 76) (KEYBOARDBEEP 80) (
KEYBOARDMAP 81) (KEYBOARDSTATE 82) (VMEMSAVE 89) (LISP-FINISH 90) (NEWPAGE 91) (DORECLAIM 92) (
DUMMY-135Q 93) (NATIVE-MEMORY-REFERENCE 94) (OLD-COMPILE-LOAD-NATIVE 95) (DISABLEGC 96) (
COM-SETFILEINFO 103) (COM-OPENFILE 104) (COM-CLOSEFILE 105) (DSK-GETFILENAME 106) (DSK-DELETEFILE 107)
 (DSK-RENAMEFILE 108) (COM-NEXT-FILE 110) (COM-FINISH-FINFO 111) (COM-GEN-FILES 112) (
DSK-DIRECTORYNAMEP 113) (COM-GETFILEINFO 114) (COM-CHANGEDIR 116) (UNIX-HANDLECOMM 117) (RPC-CALL 119)
 (MESSAGE-READP 120) (MESSAGE-READ 121) (MONITOR-CONTROL 128) (GET-NATIVE-ADDR-FROM-LISP-PTR 131) (
GET-LISP-PTR-FROM-NATIVE-ADDR 132) (LOAD-NATIVE-FILE 133) (SUSPEND-LISP 134) (NEW-BLTCHAR 135) (
COLOR-INIT 136) (COLOR-SCREENMODE 137) (COLOR-MAP 138) (COLOR-BASE 139) (|C-SlowBltChar| 140) (
UNCOLORIZE-BITMAP 141) (COLORIZE-BITMAP 142) (COLOR-8BPPDRAWLINE 143) (TCP-OP 144) (WITH-SYMBOL 145) (
CAUSE-INTERRUPT 146) (OPEN-SOCKET 160) (CLOSE-SOCKET 161) (READ-SOCKET 162) (WRITE-SOCKET 163) (
CALL-C-FUNCTION 167) (DLD-LINK 168) (DLD-UNLINK-BY-FILE 169) (DLD-UNLINK-BY-SYMBOL 170) (
DLD-GET-SYMBOL 171) (DLD-GET-FUNC 172) (DLD-FUNCTION-EXECUTABLE-P 173) (DLD-LIST-UNDEFINED-SYMBOLS 174
) (C-MALLOC 175) (C-FREE 176) (C-PUTBASEBYTE 177) (C-GETBASEBYTE 178) (CHAR-OPENFILE 200) (CHAR-BIN 
201) (CHAR-BOUT 202) (CHAR-IOCTL 203) (CHAR-CLOSEFILE 204) (CHAR-EOFP 205) (CHAR-READP 206) (CHAR-BINS
 207) (CHAR-BOUTS 208) (CHAR-FILLBUFFER 209)))
(PUTPROP (QUOTE LLSUBRS) (QUOTE IMPORTDATE) (IDATE "17-Dec-1992 14:28:41"))

STOP

\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(LISPXPRIN1 "EXPORTS GATHERED FROM {DSK}<home>larry>ilisp>medley>sources> ON 14-Feb-2021 00:15:53"  T)
(LISPXTERPRI T)
(PUTPROP (QUOTE FILESETS) (QUOTE IMPORTDATE) (IDATE " 7-Feb-2021 20:03:00"))

(RPAQQ MODARITHMACROS (CEIL FLOOR FOLDHI FOLDLO MODUP UNFOLD MOD))
(PUTPROPS CEIL MACRO ((X N) (FLOOR (IPLUS X (CONSTANT (SUB1 N))) N)))
(PUTPROPS FLOOR MACRO ((X N) (LOGAND X (CONSTANT (LOGXOR (SUB1 N) -1)))))
(PUTPROPS FOLDHI MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR (
AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) (LIST (QUOTE 
IPLUS) FORM (SUB1 DIVISOR)) (SUB1 (INTEGERLENGTH DIVISOR)))))))
(PUTPROPS FOLDLO MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR (
AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LRSH) FORM (SUB1 (
INTEGERLENGTH DIVISOR)))))))
(PUTPROPS MODUP MACRO (OPENLAMBDA (X N) (IDIFFERENCE (SUB1 N) (IMOD (SUB1 X) N))))
(PUTPROPS UNFOLD MACRO (X (PROG ((FORM (CAR X)) (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X))))) (OR (
AND DIVISOR (POWEROFTWOP DIVISOR)) (\\ILLEGAL.ARG (CADR X))) (RETURN (LIST (QUOTE LLSH) FORM (SUB1 (
INTEGERLENGTH DIVISOR)))))))
(PUTPROPS MOD MACRO (= . IMOD))
(RPAQQ BITSPERNIBBLE 4)
(RPAQQ NIBBLESPERBYTE 2)
(RPAQQ BITSPERBYTE 8)
(RPAQQ BITSPERCELL 32)
(RPAQQ BITSPERWORD 16)
(RPAQQ BYTESPERCELL 4)
(RPAQQ BYTESPERPAGE 512)
(RPAQQ BYTESPERWORD 2)
(RPAQQ CELLSPERPAGE 128)
(RPAQQ CELLSPERSEGMENT 32768)
(RPAQQ PAGESPERSEGMENT 256)
(RPAQQ WORDSPERCELL 2)
(RPAQQ WORDSPERPAGE 256)
(RPAQQ WORDSPERSEGMENT 65536)
(RPAQQ WORDSPERQUAD 4)
(RPAQQ CELLSPERQUAD 2)
(RPAQQ BYTESPERQUAD 8)
(CONSTANTS BITSPERNIBBLE NIBBLESPERBYTE BITSPERBYTE BITSPERCELL BITSPERWORD BYTESPERCELL BYTESPERPAGE 
BYTESPERWORD CELLSPERPAGE CELLSPERSEGMENT PAGESPERSEGMENT WORDSPERCELL WORDSPERPAGE WORDSPERSEGMENT 
WORDSPERQUAD CELLSPERQUAD BYTESPERQUAD)
(RPAQQ INTEGERSIZECONSTANTS ((BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP
)) (MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP (
IDIFFERENCE -1 MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP (
LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 
MAX.FIXP))))
(RPAQ BITS.PER.SMALLP (ADD1 BITSPERWORD))
(RPAQ SMALLP.LENGTH (SUB1 BITS.PER.SMALLP))
(RPAQ MAX.SMALLP (LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH)))))
(RPAQ MIN.SMALLP (IDIFFERENCE -1 MAX.SMALLP))
(RPAQ BITS.PER.FIXP BITSPERCELL)
(RPAQ FIXP.LENGTH (SUB1 BITS.PER.FIXP))
(RPAQ MAX.FIXP (LOGOR (LSH 1 (SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH)))))
(RPAQ MIN.FIXP (IDIFFERENCE -1 MAX.FIXP))
(CONSTANTS (BITS.PER.SMALLP (ADD1 BITSPERWORD)) (SMALLP.LENGTH (SUB1 BITS.PER.SMALLP)) (MAX.SMALLP (
LOGOR (LSH 1 (SUB1 SMALLP.LENGTH)) (SUB1 (LSH 1 (SUB1 SMALLP.LENGTH))))) (MIN.SMALLP (IDIFFERENCE -1 
MAX.SMALLP)) (BITS.PER.FIXP BITSPERCELL) (FIXP.LENGTH (SUB1 BITS.PER.FIXP)) (MAX.FIXP (LOGOR (LSH 1 (
SUB1 FIXP.LENGTH)) (SUB1 (LSH 1 (SUB1 FIXP.LENGTH))))) (MIN.FIXP (IDIFFERENCE -1 MAX.FIXP)))
(PUTPROP (QUOTE MODARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:46:21"))

(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 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10 
NIL |VMemPagePType|) (\\STREAM 11 NIL STREAMTYPE) (* |;;| 
"TYPE TABLE CONSTANTS - - - - - - - - - - - - - - - - - - - - - -") (\\TT.TYPEMASK 2047 |TTTypeMask| T
) (\\TT.NOREF 32768 NIL T) (\\TT.SYMBOLP 16384 NIL T) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 
2048) (* |;;| "page map - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -") 
(|\\PMblockSize| 32 PMBLOCKSIZE) (|\\STATSsize| 8 T) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535 T) (
|\\FirstVmemBlock| 2 T) (\\MAXVMPAGE 131069) (\\MAXVMSEGMENT 255) (* |;;| "interface page") (
|\\IFPValidKey| 5603 T) (* |;;| "MDS") (|\\FirstMDSPage| 32766) (* \; "Was 37776Q pre 16-meg intiial")
 (|\\MaxMDSPage| 524285) (|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512) (|\\PagesPerMDSUnit| 
2) (* \; "(FOLDLO \\MDSIncrement WORDSPERPAGE)") (* |;;| "arrays") (\\ARRAYSPACE (46 0)) (
|\\FirstArraySegment| 46) (|\\FirstArrayPage| 11776) (\\ARRAYSPACE2 (64 0)) (
|\\DefaultSecondArrayPage| 32768) (* \; "Was 40000Q before 16meg initial") (* |;;| 
"stack block constants") (|\\StackMask| 57344 T T) (|\\FxtnBlock| 49152 T T) (|\\GuardBlock| 57344 T T
) (|\\BFBlock| 32768 T T) (|\\FreeStackBlock| 40960 T T) (|\\NotStackBlock| 0) (* \; 
"none of the above") (|\\MinExtraStackWords| 32 T T) (* |;;| "backspace kludge") (ERASECHARCODE 0 T) (
* |;;| "GC constants") (\\HT1CNT 1024 NIL T) (\\HTSTKBIT 512 NIL T) (\\HTCNTMASK 64512 NIL T) (
\\HTMAINSIZE 65536 NIL T) (\\HTCOLLSIZE 1048576 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| (21 0) (|AHTspace| 
|AHTbase|)) (|\\AtomHTpages| 256 AHTSIZE) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) (
\\SMALLPOSPSPACE (14 0)) (|\\SmallPosHi| 14 |SMALLPOSspace| |smallpl|) (\\SMALLNEGSPACE (15 0)) (
|\\SmallNegHi| 15 |SMALLNEGspace| |smallneg|) (|\\NumSmallPages| 512) (* |;;| 
"PNAME SPACEin the old world; used for initial atoms now.") (\\PNPSPACE (8 0) (|PNPspace| |PNPbase|)) 
(\\PNAME.HI 8) (\\OLDATOMSPACE (44 0)) (* \; "NEW ATOM SPACE") (\\ATOM.HI 44) (* \; 
"HI PART OF NEW ATOM SPACE") (* |;;| "Definitions in old atom world") (\\DEFSPACE (10 0) (|DEFspace| 
|DEFbase|) (|DEFspace| |DEFbase|)) (\\DEF.HI 10) (\\VALSPACE (12 0) (|TOPVALspace| |TOPVALbase|) (
|VALspace| |VALbase|)) (\\VAL.HI 12) (\\PLISTSPACE (2 0) (|PLISTspace| |PLISTbase|)) (\\PLIST.HI 2) (
\\PAGEMAP (5 0) (|PAGEMAPspace| |PAGEMAPbase|)) (|\\NumPageMapPages| 256) (|\\PageMapTBL| (20 512) (
|PMTspace| |PMTbase|)) (|\\InterfacePage| (20 0) (|INTERFACEspace| |INTERFACEbase|) (|INTERFACEspace| 
|INTERFACEbase|)) (\\IOPAGE (0 65280)) (|\\DoveIORegion| (0 16384)) (\\IOCBPAGE (0 256)) (\\FPTOVP (2 
0)) (|\\MDSTypeTable| (24 0) (|MDSTYPEspace| |MDSTYPEbase|) (|MDSTYPEspace| |MDSTYPEbase|)) (
|\\MDSTTsize| 1024 T) (* \; "in Pages") (\\MISCSTATS (20 2560) (|STATSspace| |MISCSTATSbase|)) (
|\\UFNTable| (20 3072) NIL (|STATSspace| |UFNTablebase|)) (|\\UFNTableSize| 2) (|\\DTDSpaceBase| (20 
4096) (|DTDspace| |DTDbase|) (|DTDspace| |DTDbase|)) (|\\DTDSize| 18 T) (\\LISTPDTD (20 4186)) (
|\\EndTypeNumber| 2047) (\\LOCKEDPAGETABLE (20 28672)) (|\\NumLPTPages| 16) (\\STACKSPACE (1 0) (
|STACKspace| NIL) (|STACKspace| NIL)) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 
1 T T) (\\HTMAIN (22 0) (|HTMAINspace| |HTMAINbase|) (|HTMAINspace| |HTMAINbase|)) (|\\HTMAINnpages| 
256 T) (\\HTOVERFLOW (23 0) NIL (NIL |HTOVERFLOWbase|)) (\\HTBIGCOUNT (23 32768)) (\\HTCOLL (28 0) NIL
 (|HTCOLLspace| |HTCOLLbase|)) (\\DISPLAYREGION (18 0)) (|\\D1BCPLspace| 0 T |LEmubrHiVal|) (
|\\D0BCPLspace| 0 T) (* |;;| "Interface Page locations") (|\\CurrentFXP| 0 T T) (|\\ResetFXP| 1 T T) (
|\\SubovFXP| 2 T T) (|\\KbdFXP| 3 T T) (|\\HardReturnFXP| 4 T T) (\\GCFXP 5) (\\FAULTFXP 6 T T) (
|\\MiscFXP| 14 T T) (|\\TeleRaidFXP| 24 T T) (* |;;| "emulator segment locations") (DCB.EM 272) (
DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (KBDAD1.EM 65053) (KBDAD2.EM 65054) (
KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 279) (MOUSEX.EM 276) (MOUSEY.EM 277) (
|\\LispKeyMask| 8192 T T) (|\\BcplKeyMask| 4352 T T) (* \; "Machine types") (\\MAIKO 3) (\\DOLPHIN 4) 
(\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (* |;;| "FOR DLION (AND DAYBREAK)") (\\VP.DISPLAY 4608) (
\\NP.DISPLAY 202) (* \; "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)") (
\\NP.WIDEDOVEDISPLAY 243) (* \; "Wide Dove display 1152x864 pixels") (\\WIDEDOVEDISPLAYWIDTH 1152) (
\\RP.AFTERDISPLAY 206) (* \; "Includes 4 pages for cursor") (\\RP.AFTERDOVEDISPLAY 243) (* \; 
"if big screen") (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (* \; 
"(+ \\RP.TEMPDISPLAY \\NP.WIDEDOVEDISPLAY)") (\\RP.STACK 768) (\\VP.STACK 256) (\\RP.MAP 256) (
\\NP.MAP 256) (\\RP.IOPAGE 512) (* \; 
"The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range") (\\RP.DOVEIOCBPAGE 543) (
\\RP.DOVEIORGN 544) (\\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 5120) (
\\VP.FPTOVP 512) (\\NP.FPTOVP 4096) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 6144) (
\\NP.TYPETABLE 1024) (\\RP.TYPETABLE 5120) (\\VP.GCTABLE 5632) (\\NP.GCTABLE 256) (\\RP.GCTABLE 6144) 
(\\VP.GCOVERFLOW 5888) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 6400) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) (
\\VP.PRIMARYMAP 5122) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 5232) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) (
\\VP.BUFFERS 218) (* \; "DLion processor commands") (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) (
\\DL.READTOD 32770) (\\DL.READPID 32771) (\\DL.BOOTBUTTON 32772)))
(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 18 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 32 WORD) (DLIOPHARDWARECONFIG WORD)
 (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) (DLRS232CPARAMETERCSBHI.11 WORD) (
DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) (DLETHERNET 12 WORD NIL T) (NIL 31
 WORD) (DLDISPINTERRUPT WORD NIL T) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) (DLCURSORX WORD NIL T) (
DLCURSORY WORD NIL T) (DLCURSORBITMAP 16 WORD NIL T)))
(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 8)
(RPAQQ \\CHARACTERP 9)
(RPAQQ \\VMEMPAGEP 10)
(RPAQQ \\STREAM 11)
(RPAQQ \\TT.TYPEMASK 2047)
(RPAQQ \\TT.NOREF 32768)
(RPAQQ \\TT.SYMBOLP 16384)
(RPAQQ \\TT.FIXP 8192)
(RPAQQ \\TT.NUMBERP 4096)
(RPAQQ \\TT.ATOM 2048)
(RPAQQ |\\PMblockSize| 32)
(RPAQQ |\\STATSsize| 8)
(RPAQQ |\\NumPMTpages| 8)
(RPAQQ |\\EmptyPMTEntry| 65535)
(RPAQQ |\\FirstVmemBlock| 2)
(RPAQQ \\MAXVMPAGE 131069)
(RPAQQ \\MAXVMSEGMENT 255)
(RPAQQ |\\IFPValidKey| 5603)
(RPAQQ |\\FirstMDSPage| 32766)
(RPAQQ |\\MaxMDSPage| 524285)
(RPAQQ |\\DefaultSecondMDSPage| 65532)
(RPAQQ |\\MDSIncrement| 512)
(RPAQQ |\\PagesPerMDSUnit| 2)
(RPAQQ |\\FirstArraySegment| 46)
(RPAQQ |\\FirstArrayPage| 11776)
(RPAQQ |\\DefaultSecondArrayPage| 32768)
(RPAQQ |\\StackMask| 57344)
(RPAQQ |\\FxtnBlock| 49152)
(RPAQQ |\\GuardBlock| 57344)
(RPAQQ |\\BFBlock| 32768)
(RPAQQ |\\FreeStackBlock| 40960)
(RPAQQ |\\NotStackBlock| 0)
(RPAQQ |\\MinExtraStackWords| 32)
(RPAQQ ERASECHARCODE 0)
(RPAQQ \\HT1CNT 1024)
(RPAQQ \\HTSTKBIT 512)
(RPAQQ \\HTCNTMASK 64512)
(RPAQQ \\HTMAINSIZE 65536)
(RPAQQ \\HTCOLLSIZE 1048576)
(RPAQQ \\HTENDFREE 1)
(RPAQQ \\HTFREEPTR 0)
(RPAQQ |\\AtomHI| 0)
(RPAQQ \\CHARHI 7)
(RPAQQ |\\AtomHTpages| 256)
(RPAQQ |\\LastAtomPage| 255)
(RPAQQ |\\MaxAtomFrLst| 65535)
(RPAQQ |\\SmallPosHi| 14)
(RPAQQ |\\SmallNegHi| 15)
(RPAQQ |\\NumSmallPages| 512)
(RPAQQ \\PNAME.HI 8)
(RPAQQ \\ATOM.HI 44)
(RPAQQ \\DEF.HI 10)
(RPAQQ \\VAL.HI 12)
(RPAQQ \\PLIST.HI 2)
(RPAQQ |\\NumPageMapPages| 256)
(RPAQQ |\\MDSTTsize| 1024)
(RPAQQ |\\UFNTableSize| 2)
(RPAQQ |\\DTDSize| 18)
(RPAQQ |\\EndTypeNumber| 2047)
(RPAQQ |\\NumLPTPages| 16)
(RPAQQ |\\GuardStackAddr| 61440)
(RPAQQ |\\LastStackAddr| 65534)
(RPAQQ \\STACKHI 1)
(RPAQQ |\\HTMAINnpages| 256)
(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| 14)
(RPAQQ |\\TeleRaidFXP| 24)
(RPAQQ DCB.EM 272)
(RPAQQ DISPINTERRUPT.EM 273)
(RPAQQ CURSORBITMAP.EM 281)
(RPAQQ KBDAD0.EM 65052)
(RPAQQ KBDAD1.EM 65053)
(RPAQQ KBDAD2.EM 65054)
(RPAQQ KBDAD3.EM 65055)
(RPAQQ UTILIN.EM 65048)
(RPAQQ CURSORX.EM 278)
(RPAQQ CURSORY.EM 279)
(RPAQQ MOUSEX.EM 276)
(RPAQQ MOUSEY.EM 277)
(RPAQQ |\\LispKeyMask| 8192)
(RPAQQ |\\BcplKeyMask| 4352)
(RPAQQ \\MAIKO 3)
(RPAQQ \\DOLPHIN 4)
(RPAQQ \\DORADO 5)
(RPAQQ \\DANDELION 6)
(RPAQQ \\DAYBREAK 8)
(RPAQQ \\VP.DISPLAY 4608)
(RPAQQ \\NP.DISPLAY 202)
(RPAQQ \\NP.WIDEDOVEDISPLAY 243)
(RPAQQ \\WIDEDOVEDISPLAYWIDTH 1152)
(RPAQQ \\RP.AFTERDISPLAY 206)
(RPAQQ \\RP.AFTERDOVEDISPLAY 243)
(RPAQQ \\RP.DISPLAY 0)
(RPAQQ \\RP.TEMPDISPLAY 2561)
(RPAQQ \\RP.MISCLOCKED 2804)
(RPAQQ \\RP.STACK 768)
(RPAQQ \\VP.STACK 256)
(RPAQQ \\RP.MAP 256)
(RPAQQ \\NP.MAP 256)
(RPAQQ \\RP.IOPAGE 512)
(RPAQQ \\RP.DOVEIOCBPAGE 543)
(RPAQQ \\RP.DOVEIORGN 544)
(RPAQQ \\VP.DOVEIORGN 64)
(RPAQQ \\DOVEIORGNSIZE 64)
(RPAQQ \\VP.IOPAGE 255)
(RPAQQ \\VP.IFPAGE 5120)
(RPAQQ \\VP.FPTOVP 512)
(RPAQQ \\NP.FPTOVP 4096)
(RPAQQ \\RP.FPTOVP 1024)
(RPAQQ \\RP.STARTBUFFERS 640)
(RPAQQ \\VP.TYPETABLE 6144)
(RPAQQ \\NP.TYPETABLE 1024)
(RPAQQ \\RP.TYPETABLE 5120)
(RPAQQ \\VP.GCTABLE 5632)
(RPAQQ \\NP.GCTABLE 256)
(RPAQQ \\RP.GCTABLE 6144)
(RPAQQ \\VP.GCOVERFLOW 5888)
(RPAQQ \\NP.GCOVERFLOW 1)
(RPAQQ \\RP.GCOVERFLOW 6400)
(RPAQQ \\FP.IFPAGE 2)
(RPAQQ \\VP.IOCBS 1)
(RPAQQ \\VP.PRIMARYMAP 5122)
(RPAQQ \\VP.SECONDARYMAP 1280)
(RPAQQ \\VP.LPT 5232)
(RPAQQ \\VP.INITSCRATCH 8)
(RPAQQ \\VP.RPT 128)
(RPAQQ \\VP.BUFFERS 218)
(RPAQQ \\DL.PROCESSORBUSY 32768)
(RPAQQ \\DL.SETTOD 32769)
(RPAQQ \\DL.READTOD 32770)
(RPAQQ \\DL.READPID 32771)
(RPAQQ \\DL.BOOTBUTTON 32772)
(CONSTANTS (CDRCODING 1) (\\SMALLP 1) (\\FIXP 2) (\\FLOATP 3) (\\LITATOM 4) (\\LISTP 5) (\\ARRAYP 6) (
\\STRINGP 7) (\\STACKP 8) (\\CHARACTERP 9) (\\VMEMPAGEP 10) (\\STREAM 11) (\\TT.TYPEMASK 2047) (
\\TT.NOREF 32768) (\\TT.SYMBOLP 16384) (\\TT.FIXP 8192) (\\TT.NUMBERP 4096) (\\TT.ATOM 2048) (
|\\PMblockSize| 32) (|\\STATSsize| 8) (|\\NumPMTpages| 8) (|\\EmptyPMTEntry| 65535) (
|\\FirstVmemBlock| 2) (\\MAXVMPAGE 131069) (\\MAXVMSEGMENT 255) (|\\IFPValidKey| 5603) (
|\\FirstMDSPage| 32766) (|\\MaxMDSPage| 524285) (|\\DefaultSecondMDSPage| 65532) (|\\MDSIncrement| 512
) (|\\PagesPerMDSUnit| 2) (|\\FirstArraySegment| 46) (|\\FirstArrayPage| 11776) (
|\\DefaultSecondArrayPage| 32768) (|\\StackMask| 57344) (|\\FxtnBlock| 49152) (|\\GuardBlock| 57344) (
|\\BFBlock| 32768) (|\\FreeStackBlock| 40960) (|\\NotStackBlock| 0) (|\\MinExtraStackWords| 32) (
ERASECHARCODE 0) (\\HT1CNT 1024) (\\HTSTKBIT 512) (\\HTCNTMASK 64512) (\\HTMAINSIZE 65536) (
\\HTCOLLSIZE 1048576) (\\HTENDFREE 1) (\\HTFREEPTR 0) (|\\AtomHI| 0) (\\CHARHI 7) (|\\AtomHTpages| 256
) (|\\LastAtomPage| 255) (|\\MaxAtomFrLst| 65535) (|\\SmallPosHi| 14) (|\\SmallNegHi| 15) (
|\\NumSmallPages| 512) (\\PNAME.HI 8) (\\ATOM.HI 44) (\\DEF.HI 10) (\\VAL.HI 12) (\\PLIST.HI 2) (
|\\NumPageMapPages| 256) (|\\MDSTTsize| 1024) (|\\UFNTableSize| 2) (|\\DTDSize| 18) (|\\EndTypeNumber|
 2047) (|\\NumLPTPages| 16) (|\\GuardStackAddr| 61440) (|\\LastStackAddr| 65534) (\\STACKHI 1) (
|\\HTMAINnpages| 256) (|\\D1BCPLspace| 0) (|\\D0BCPLspace| 0) (|\\CurrentFXP| 0) (|\\ResetFXP| 1) (
|\\SubovFXP| 2) (|\\KbdFXP| 3) (|\\HardReturnFXP| 4) (\\GCFXP 5) (\\FAULTFXP 6) (|\\MiscFXP| 14) (
|\\TeleRaidFXP| 24) (DCB.EM 272) (DISPINTERRUPT.EM 273) (CURSORBITMAP.EM 281) (KBDAD0.EM 65052) (
KBDAD1.EM 65053) (KBDAD2.EM 65054) (KBDAD3.EM 65055) (UTILIN.EM 65048) (CURSORX.EM 278) (CURSORY.EM 
279) (MOUSEX.EM 276) (MOUSEY.EM 277) (|\\LispKeyMask| 8192) (|\\BcplKeyMask| 4352) (\\MAIKO 3) (
\\DOLPHIN 4) (\\DORADO 5) (\\DANDELION 6) (\\DAYBREAK 8) (\\VP.DISPLAY 4608) (\\NP.DISPLAY 202) (
\\NP.WIDEDOVEDISPLAY 243) (\\WIDEDOVEDISPLAYWIDTH 1152) (\\RP.AFTERDISPLAY 206) (\\RP.AFTERDOVEDISPLAY
 243) (\\RP.DISPLAY 0) (\\RP.TEMPDISPLAY 2561) (\\RP.MISCLOCKED 2804) (\\RP.STACK 768) (\\VP.STACK 256
) (\\RP.MAP 256) (\\NP.MAP 256) (\\RP.IOPAGE 512) (\\RP.DOVEIOCBPAGE 543) (\\RP.DOVEIORGN 544) (
\\VP.DOVEIORGN 64) (\\DOVEIORGNSIZE 64) (\\VP.IOPAGE 255) (\\VP.IFPAGE 5120) (\\VP.FPTOVP 512) (
\\NP.FPTOVP 4096) (\\RP.FPTOVP 1024) (\\RP.STARTBUFFERS 640) (\\VP.TYPETABLE 6144) (\\NP.TYPETABLE 
1024) (\\RP.TYPETABLE 5120) (\\VP.GCTABLE 5632) (\\NP.GCTABLE 256) (\\RP.GCTABLE 6144) (
\\VP.GCOVERFLOW 5888) (\\NP.GCOVERFLOW 1) (\\RP.GCOVERFLOW 6400) (\\FP.IFPAGE 2) (\\VP.IOCBS 1) (
\\VP.PRIMARYMAP 5122) (\\VP.SECONDARYMAP 1280) (\\VP.LPT 5232) (\\VP.INITSCRATCH 8) (\\VP.RPT 128) (
\\VP.BUFFERS 218) (\\DL.PROCESSORBUSY 32768) (\\DL.SETTOD 32769) (\\DL.READTOD 32770) (\\DL.READPID 
32771) (\\DL.BOOTBUTTON 32772))
(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 8 "Loop in \\SELECTREALPAGE") (
\\MP.NEWPAGE 9 "Attempt to allocate already existing page") (\\MP.NEWMAPPAGE 10 
"\\DONEWPAGE failed to allocate new map page") (\\MP.BADLOCKED 11 
"Locked page occupies a file page needed to lock another") (\\MP.CLOCK0 12 
"Arg to CLOCK0 not an integer box") (\\MP.RESIDENT 13 "Fault on resident page") (\\MP.STACKFAULT 14 
"Fault on stack") (\\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") (
\\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\\MP.UNINTERRUPTABLE 18 
"Error in uninterruptable system code") (\\MP.STACKFULL 19) (\\MP.MDSFULL 20) (\\MP.UNKNOWN.UFN 21) (
\\MP.ATOMSFULL 22) (\\MP.PNAMESFULL 23) (\\MP.USECOUNTOVERFLOW 24) (\\MP.MDSFULLWARNING 25) (
\\MP.BADMDSFREELIST 26) (\\MP.BADARRAYBLOCK 27) (\\MP.BADDELETEBLOCK 28) (\\MP.BADARRAYRECLAIM 29) (
\\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") (
\\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\\MP.DELREF0 32) (\\MP.PROCERROR 33)
 (\\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\\MP.32MBINUSE 35) (\\MP.TOPUNWOUND 36
 "Unexpected (RETTO T)") (\\MP.STACKRELEASED 37) (\\MP.FLUSHLOCKED 38) (\\MP.MAPNOTLOCKED 39) (
\\MP.UNLOCKINGMAP 40) (\\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\\MP.BADRUNTABLE 42 
"Malformed run table for vmem file")))
(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 8 "Loop in \\SELECTREALPAGE")
(RPAQ \\MP.NEWPAGE 9 "Attempt to allocate already existing page")
(RPAQ \\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page")
(RPAQ \\MP.BADLOCKED 11 "Locked page occupies a file page needed to lock another")
(RPAQ \\MP.CLOCK0 12 "Arg to CLOCK0 not an integer box")
(RPAQ \\MP.RESIDENT 13 "Fault on resident page")
(RPAQ \\MP.STACKFAULT 14 "Fault on stack")
(RPAQ \\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)")
(RPAQ \\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T")
(RPAQ \\MP.UNINTERRUPTABLE 18 "Error in uninterruptable system code")
(RPAQQ \\MP.STACKFULL 19)
(RPAQQ \\MP.MDSFULL 20)
(RPAQQ \\MP.UNKNOWN.UFN 21)
(RPAQQ \\MP.ATOMSFULL 22)
(RPAQQ \\MP.PNAMESFULL 23)
(RPAQQ \\MP.USECOUNTOVERFLOW 24)
(RPAQQ \\MP.MDSFULLWARNING 25)
(RPAQQ \\MP.BADMDSFREELIST 26)
(RPAQQ \\MP.BADARRAYBLOCK 27)
(RPAQQ \\MP.BADDELETEBLOCK 28)
(RPAQQ \\MP.BADARRAYRECLAIM 29)
(RPAQ \\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.")
(RPAQ \\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table")
(RPAQQ \\MP.DELREF0 32)
(RPAQQ \\MP.PROCERROR 33)
(RPAQ \\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use")
(RPAQQ \\MP.32MBINUSE 35)
(RPAQ \\MP.TOPUNWOUND 36 "Unexpected (RETTO T)")
(RPAQQ \\MP.STACKRELEASED 37)
(RPAQQ \\MP.FLUSHLOCKED 38)
(RPAQQ \\MP.MAPNOTLOCKED 39)
(RPAQQ \\MP.UNLOCKINGMAP 40)
(RPAQ \\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper")
(RPAQ \\MP.BADRUNTABLE 42 "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 
8 "Loop in \\SELECTREALPAGE") (\\MP.NEWPAGE 9 "Attempt to allocate already existing page") (
\\MP.NEWMAPPAGE 10 "\\DONEWPAGE failed to allocate new map page") (\\MP.BADLOCKED 11 
"Locked page occupies a file page needed to lock another") (\\MP.CLOCK0 12 
"Arg to CLOCK0 not an integer box") (\\MP.RESIDENT 13 "Fault on resident page") (\\MP.STACKFAULT 14 
"Fault on stack") (\\MP.VMEMTOOLONG 16 "Attempt to extend Vmem File beyond fixed limit (8mb)") (
\\MP.WRITING.LOCKED.PAGE 17 "Writing a locked page with UPDATEKEY = T") (\\MP.UNINTERRUPTABLE 18 
"Error in uninterruptable system code") (\\MP.STACKFULL 19) (\\MP.MDSFULL 20) (\\MP.UNKNOWN.UFN 21) (
\\MP.ATOMSFULL 22) (\\MP.PNAMESFULL 23) (\\MP.USECOUNTOVERFLOW 24) (\\MP.MDSFULLWARNING 25) (
\\MP.BADMDSFREELIST 26) (\\MP.BADARRAYBLOCK 27) (\\MP.BADDELETEBLOCK 28) (\\MP.BADARRAYRECLAIM 29) (
\\MP.BIGREFCNTMISSING 30 "PTR refcnt previously overflowed, but not found in table.") (
\\MP.BIGREFCNTALREADYPRESENT 31 "PTR already in overflow table") (\\MP.DELREF0 32) (\\MP.PROCERROR 33)
 (\\MP.PROCNOFRAME 34 "Failed to build frame for PROCESS use") (\\MP.32MBINUSE 35) (\\MP.TOPUNWOUND 36
 "Unexpected (RETTO T)") (\\MP.STACKRELEASED 37) (\\MP.FLUSHLOCKED 38) (\\MP.MAPNOTLOCKED 39) (
\\MP.UNLOCKINGMAP 40) (\\MP.SWAPDISKERROR 41 "Hard Disk Error in swapper") (\\MP.BADRUNTABLE 42 
"Malformed run table for vmem file"))
(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 31)))
(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 43)))
(BLOCKRECORD IOPAGE ((NIL 18 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 32 WORD) (DLIOPHARDWARECONFIG WORD) (NIL 11 WORD) (DLRS232CPARAMETERCSBLO.11 WORD) (
DLRS232CPARAMETERCSBHI.11 WORD) (DLRS232CSETRS366STATUS.11 14 WORD) (NIL 60 WORD) (DLMAGTAPE 4 WORD) (
DLETHERNET 12 WORD) (NIL 31 WORD) (DLDISPINTERRUPT WORD) (DLDISPCONTROL WORD) (DLDISPBORDER WORD) (
DLCURSORX WORD) (DLCURSORY WORD) (DLCURSORBITMAP 16 WORD)) (ACCESSFNS IOPAGE ((DLCURSORBITMAPPTR (
\\ADDBASE DATUM 240)) (DLCURSORYPTR (\\ADDBASE DATUM 239)) (DLCURSORXPTR (\\ADDBASE DATUM 238)) (
DLDISPINTERRUPTPTR (\\ADDBASE DATUM 235)) (DLETHERNETPTR (\\ADDBASE DATUM 192)) (DLKBDAD5PTR (
\\ADDBASE DATUM 67)) (DLKBDAD4PTR (\\ADDBASE DATUM 66)) (DLKBDAD3PTR (\\ADDBASE DATUM 65)) (
DLKBDAD2PTR (\\ADDBASE DATUM 64)) (DLKBDAD1PTR (\\ADDBASE DATUM 63)) (DLKBDAD0PTR (\\ADDBASE DATUM 62)
) (DLUTILINPTR (\\ADDBASE DATUM 61)) (DLMOUSEYPTR (\\ADDBASE DATUM 60)) (DLMOUSEXPTR (\\ADDBASE DATUM 
59)) (DLTODLOPTR (\\ADDBASE DATUM 56)) (DLMAINTPANELPTR (\\ADDBASE DATUM 18)))) (CREATE (\\ALLOCBLOCK 
128)))
(PUTPROPS EMADDRESS MACRO (ARGS ((LAMBDA (ADDR) (COND ((EQ |\\D1BCPLspace| |\\D0BCPLspace|) (LIST (
LIST (QUOTE OPCODES) (QUOTE GCONST) 0 0 (LRSH ADDR 8) (LOGAND ADDR 255)))) (T (BQUOTE (\\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 (QUOTE \\VAG2) (QUOTE 
(|fetch| (IFPAGE |EmulatorSpace|) |of| |\\InterfacePage|)) (CAR X))) ((ZEROP (CAR X)) NIL) (T (LIST (
QUOTE \\VAG2) |\\D0BCPLspace| (CAR X))))))
(PUTPROPS EMADDRESSP MACRO (X (LIST (QUOTE EQ) (LIST (QUOTE \\HILOC) (CAR X)) (COND ((EQ 
|\\D1BCPLspace| |\\D0BCPLspace|) |\\D0BCPLspace|) (T (QUOTE (|fetch| (IFPAGE |EmulatorSpace|) |of| 
|\\InterfacePage|)))))))
(PUTPROP (QUOTE LLPARAMS) (QUOTE IMPORTDATE) (IDATE " 7-Feb-2021 11:52:02"))

(DATATYPE COMPILED-CLOSURE (FNHEADER ENVIRONMENT))
(RPAQQ \\COMPILED-CLOSURE 13)
(CONSTANTS \\COMPILED-CLOSURE)
(PUTPROPS \\EXTENDED.EQP MACRO (OPENLAMBDA (X Y) (COND ((EQ (NTYPX X) (NTYPX Y)) (SELECTC (NTYPX X) (
\\STACKP (EQ (|fetch| (STACKP EDFXP) |of| X) (|fetch| (STACKP EDFXP) |of| Y))) (\\COMPILED-CLOSURE (
EQDEFP X Y)) NIL)))))
(PUTPROPS DPUTCODE MACRO ((FN CA SIZE) (SELECTQ (SYSTEMTYPE) (D (DEFC FN CA)) (/PUTPROP FN (QUOTE 
DCODE) CA))))
(PUTPROPS MCODEP MACRO ((X) (OR (ARRAYP X) (AND (LITATOM X) (ARRAYP (SELECTQ (SYSTEMTYPE) (D (GETD X))
 (GETPROP X (QUOTE DCODE))))))))
(PUTPROPS CODELT MACRO ((CA N) (\\BYTELT CA N)))
(PUTPROPS CODELT2 MACRO (OPENLAMBDA (DEF LC) (LOGOR (LLSH (CODELT DEF LC) BITSPERBYTE) (CODELT DEF (
ADD1 LC)))))
(PUTPROPS CODESETA2 MACRO (OPENLAMBDA (DEF LC VALUE) (CODESETA DEF LC (LRSH VALUE BITSPERBYTE)) (
CODESETA DEF (ADD1 LC) (IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE))))))
(PUTPROPS CODESETA MACRO ((CA N NV) (\\BYTESETA CA N NV)))
(PUTPROPS BYTESPERNAMEENTRY MACRO (NIL (UNFOLD (CONSTANT (WORDSPERNAMEENTRY)) BYTESPERWORD)))
(PUTPROPS BYTESPERNTOFFSETENTRY MACRO (NIL (UNFOLD (WORDSPERNAMEENTRY) BYTESPERWORD)))
(PUTPROPS GETNAMEENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (* |;;| 
"Must ALWAYS be called with DEF really being either a FNHEADER or a nametable pseudo-fnheader.  Never use addbase to offset from it.  This is because CODEBASEELT checks the BYTESWAPPED flag in the fnheader...."
) (FOR I FROM 0 TO (CONSTANT (SUB1 (BYTESPERNAMEENTRY))) DO (SETQ NUMBER (LOGOR (LLSH NUMBER 
BITSPERBYTE) (CODEBASELT DEF (IPLUS LC I))))) NUMBER)))
(PUTPROPS GETNTFLAGS MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF LC)))
(PUTPROPS GETNTOFFSET MACRO (OPENLAMBDA (DEF LC) (NTSLOT-OFFSET (GETNTOFFSETENTRY DEF LC))))
(PUTPROPS GETNTOFFSETENTRY MACRO (OPENLAMBDA (DEF LC) (LET ((NUMBER 0)) (|for| I |from| 0 |to| (
CONSTANT (SUB1 (BYTESPERNTOFFSETENTRY))) |do| (SETQ NUMBER (LOGOR (LLSH NUMBER BITSPERBYTE) (
CODEBASELT DEF (IPLUS LC I))))) NUMBER)))
(PUTPROPS GETNTTAG MACRO (OPENLAMBDA (DEF LC) (CODEBASELT DEF (ADD1 LC))))
(PUTPROPS SETNAMEENTRY MACRO (OPENLAMBDA (DEF LC VALUE) (FOR I FROM (CONSTANT (SUB1 (BYTESPERNAMEENTRY
))) TO 0 BY -1 DO (CODEBASESETA DEF (IPLUS LC I) (LOGAND VALUE (CONSTANT (SUB1 (LLSH 1 BITSPERBYTE))))
) (SETQ VALUE (LRSH VALUE BITSPERBYTE)))))
(PUTPROPS WORDSPERNTOFFSETENTRY MACRO (NIL (WORDSPERNAMEENTRY)))
(PUTPROPS NTSLOT-OFFSET MACRO ((X) (LOGAND 255 X)))
(DEFMACRO NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM) (* |;;| 
"Use one form or another, depending on whether we're compiling for new 3-byte atoms or old 2-byte atom numbers."
) (COND ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*) (* \; "NEW ATOMS") (BQUOTE (\\\, 
NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, OLD-SYMBOL-FORM)))))
(DEFOPTIMIZER BIG-VMEM-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* |;;| 
"Allow for differences between 4-byte pointers and 3-byte pointers..") (COND ((FMEMB :4-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, 
OLD-SYMBOL-FORM)))))
(DEFOPTIMIZER SETSTKNAMEENTRY (CODEARRAY OFFSET VAL &ENVIRONMENT ENV) (* |;;| 
"Set the name entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE
 ENV)) (BQUOTE (LET ((BASE (|fetch| (ARRAYP BASE) |of| (\\\, CODEARRAY))) (VALUE (\\\, VAL))) (COND ((
FIXP VALUE) (* \; "A 20-byte atom #.  Make it an atom.") (\\PUTBASEPTR BASE (\\\, OFFSET) (\\VAG2 
|\\AtomHI| VALUE))) (T (* \; "A 3-byte atom.  Just use it.") (\\PUTBASEPTR BASE (\\\, OFFSET) VALUE)))
))) (T (BQUOTE (LET ((BASE (|fetch| (ARRAYP BASE) |of| (\\\, CODEARRAY)))) (\\PUTBASE BASE (\\\, 
OFFSET) (\\\, VAL)))))))
(DEFOPTIMIZER SETSTKNTOFFSETENTRY (BASE OFFSET VAL &ENVIRONMENT ENV) (* |;;| 
"Set the offset entry for a name-table entry.") (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE
 ENV)) (BQUOTE (\\PUTBASEFIXP (\\\, BASE) (\\\, OFFSET) (\\\, VAL)))) (T (BQUOTE (\\PUTBASE (\\\, BASE
) (\\\, OFFSET) (\\\, VAL))))))
(DEFOPTIMIZER GETSTKNAMEENTRY (BASE OFFSET &ENVIRONMENT ENV) (* |;;| 
"Get a name entry out of a name table.  BASE is the start of the name table; OFFSET is in words, not bytes or name entries."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\GETBASEPTR (\\\, BASE) (
\\\, OFFSET)))) (T (BQUOTE (\\GETBASE (\\\, BASE) (\\\, OFFSET))))))
(DEFOPTIMIZER GETSTKNTOFFSETENTRY (BASE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\GETBASEFIXP (\\\, BASE) (\\\, OFFSET)))) (T (BQUOTE
 (\\GETBASE (\\\, BASE) (\\\, OFFSET))))))
(DEFOPTIMIZER WORDSPERNAMEENTRY (&ENVIRONMENT ENV) (* |;;| 
"Number of words in a name-table \"Name\" entry--the space for the symbol.  1 for old symbol systems, 2 for 3-byte-atom systesm."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN 2))) ((AND 
CROSSCOMPILING (FMEMB :3-BYTE-INIT (COMPILER::ENV-TARGET-ARCHITECTURE ENV))) (BQUOTE (PROGN 2))) (T (
BQUOTE (PROGN 1)))))
(DEFOPTIMIZER SETSTKNTOFFSET (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* |;;| 
"Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\\FIXCODENUM (\\\, 
BASE) (IDIFFERENCE (\\\, OFFSET) BYTESPERWORD) (\\\, TYPE)) (\\FIXCODENUM (\\\, BASE) (\\\, OFFSET) (
\\\, VAL))))) (T (BQUOTE (\\FIXCODENUM (\\\, BASE) (\\\, OFFSET) (IPLUS (\\\, TYPE) (\\\, VAL)))))))
(DEFOPTIMIZER SETSTKNAME-RAW (BASE OFFSET VAL &ENVIRONMENT ENV) (* |;;| 
"Set the name entry for a name-table entry. This version works with raw storage, as opposed to SETSTKNAMEENTRY, which works on an ARRAYP."
) (* |;;| "If this optimizer changes, change SETSTKNAMEENTRY as well.") (COND ((FMEMB :3-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LET ((VALUE (\\\, VAL))) (COND ((FIXP VALUE) (* \; 
"A 20-byte atom #.  Make it an atom.") (\\PUTBASEPTR (\\\, BASE) (\\\, OFFSET) (\\VAG2 |\\AtomHI| 
VALUE))) (T (* \; "A 3-byte atom.  Just use it.") (\\PUTBASEPTR (\\\, BASE) (\\\, OFFSET) VALUE)))))) 
(T (BQUOTE (\\PUTBASE (\\\, BASE) (\\\, OFFSET) (\\\, VAL))))))
(DEFOPTIMIZER SETSTKNTOFFSET-RAW (BASE OFFSET TYPE VAL &ENVIRONMENT ENV) (* |;;| 
"Set the offset entry for a name-table entry.  This version works on raw storage, vs SETSTKNAMEOFFSETENTRY, which is supposed to work on codearrays.  Any changes here should be made there, as well.  TYPE must already be shifted left by 14 bits."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (PROGN (\\PUTBASE (\\\, BASE)
 (\\\, OFFSET) (\\\, TYPE)) (\\PUTBASE (\\\, BASE) (IPLUS (\\\, OFFSET) 1) (\\\, VAL))))) (T (BQUOTE (
\\PUTBASE (\\\, BASE) (\\\, OFFSET) (IPLUS (\\\, TYPE) (\\\, VAL)))))))
(DEFOPTIMIZER NEW-SYMBOL-CODE (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* |;;| 
"Allow for differences between 3-byte atoms and 2-byte atoms.") (COND ((FMEMB :3-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (\\\, NEW-SYMBOL-FORM))) (T (BQUOTE (\\\, 
OLD-SYMBOL-FORM)))))
(DEFOPTIMIZER MAKE-NTENTRY (TYPE OFFSET &ENVIRONMENT ENV) (COND ((FMEMB :3-BYTE (
COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (IPLUS (CONSTANT (LLSH (\\\, TYPE) 16)) (\\\, OFFSET))
)) (T (BQUOTE (IPLUS (CONSTANT (\\\, TYPE)) (\\\, OFFSET))))))
(DEFOPTIMIZER NULL-NTENTRY (VALUE &ENVIRONMENT ENV) (* |;;| 
"Predicate:  Is  VALUE a null entry in a name table?  I.e., does it result from fetching the entry at the end that`s all zeros?  For 2-byte atoms, that's the same as being zero.  For 3-byte atoms, it's the same as being NIL."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (NULL (\\\, VALUE)))) (T (
BQUOTE (EQ (\\\, VALUE) 0)))))
(DEFOPTIMIZER NTSLOT-VARTYPE (X &ENVIRONMENT ENV) (* |;;| 
"Given the contents of a name-table Offset entry, return the variable-type bits at the top of the entry.  THE RESULT IS RETURNED SHEFTED LEFT 14 BITS, THE USUAL REPRESENTATION."
) (COND ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) (BQUOTE (LOGAND 49153 (LRSH (\\\, X) 
16)))) (T (BQUOTE (LOGAND (\\\, X) 49152)))))
(ACCESSFNS CODEARRAY ((STKMIN (CODELT2 DATUM 0) (CODESETA2 DATUM 0 NEWVALUE)) (NA (SIGNED (CODELT2 
DATUM 2) BITSPERWORD) (CODESETA2 DATUM 2 (UNSIGNED NEWVALUE BITSPERWORD))) (PV (SIGNED (CODELT2 DATUM 
4) BITSPERWORD) (CODESETA2 DATUM 4 (UNSIGNED NEWVALUE BITSPERWORD))) (STARTPC (CODELT2 DATUM 6) (
CODESETA2 DATUM 6 NEWVALUE)) (ARGTYPE (LOGAND (LRSH (CODELT DATUM 8) 4) 3) (CODESETA DATUM 8 (LOGOR (
LOGAND (CODELT DATUM 8) 207) (LLSH (LOGAND NEWVALUE 3) 4)))) (FRAMENAME (\\VAG2 (LOGAND (CODELT2 DATUM
 8) 4095) (CODELT2 DATUM 10)) (\\FIXCODEPTR DATUM 11 (EVQ NEWVALUE))) (NTSIZE (CODELT2 DATUM 12) (
CODESETA2 DATUM 12 NEWVALUE)) (NLOCALS (CODELT DATUM 14) (CODESETA DATUM 14 NEWVALUE)) (FVAROFFSET (
CODELT DATUM 15) (CODESETA DATUM 15 NEWVALUE))) (ACCESSFNS CODEARRAY ((LSTARP (ILESSP (|fetch| (
CODEARRAY NA) |of| DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (ALIGNED (IPLUS (|fetch| (CODEARRAY NTSIZE) 
|of| DATUM) (|fetch| (CODEARRAY OVERHEADWORDS) |of| T))) (FIXED NIL (|replace| (CODEARRAY STKMIN) |of|
 DATUM |with| (\\STKMIN DATUM))) (FRAMENAME# (PROGN 8)))))
(RECORD OPCODE (OP# OPCODENAME OPNARGS OPPRINT LEVADJ UFNFN UNIMPL))
(GLOBALVARS \\OPCODES)
(RPAQQ PVARCODE 32768)
(RPAQQ FVARCODE 49152)
(RPAQQ IVARCODE 0)
(RPAQQ VARCODEMASK 49152)
(CONSTANTS PVARCODE FVARCODE IVARCODE VARCODEMASK)
(RPAQQ \\NT.IVARCODE 0)
(RPAQQ \\NT.PVARCODE 2)
(RPAQQ \\NT.FVARCODE 3)
(CONSTANTS \\NT.IVARCODE \\NT.PVARCODE \\NT.FVARCODE)
(PUTPROP (QUOTE LLCODE) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 10:45:33"))

(RPAQQ \\ERRORMESSAGELIST ("SYSTEM ERROR" " " "STACK OVERFLOW" "ILLEGAL RETURN" "ARG NOT LIST" 
"HARD DISK ERROR" "ATTEMPT TO SET NIL OR T" "ATTEMPT TO RPLAC NIL" "UNDEFINED OR ILLEGAL GO" 
"FILE WON'T OPEN" "NON-NUMERIC ARG" "ATOM TOO LONG" "ATOM HASH TABLE FULL" "FILE NOT OPEN" 
"ARG NOT LITATOM" "! too many files open" "END OF FILE" "ERROR" "BREAK" "ILLEGAL STACK ARG" 
"FAULT IN EVAL" "ARRAYS FULL" "FILE SYSTEM RESOURCES EXCEEDED" "FILE NOT FOUND" "BAD SYSOUT FILE" 
"UNUSUAL CDR ARG LIST" "HASH TABLE FULL" "ILLEGAL ARG" "ARG NOT ARRAY" "ILLEGAL OR IMPOSSIBLE BLOCK" 
"STACK PTR HAS BEEN RELEASED" "STORAGE FULL" "ATTEMPT TO USE ITEM OF INCORRECT TYPE" 
"ILLEGAL DATA TYPE NUMBER" "DATA TYPES FULL" "ATTEMPT TO BIND NIL OR T" 
"! too many user interrupt characters" "! read-macro context error" "ILLEGAL READTABLE" 
"ILLEGAL TERMINAL TABLE" "! swapblock too big for buffer" "PROTECTION VIOLATION" "BAD FILE NAME" 
"USER BREAK" "UNBOUND ATOM" "UNDEFINED CAR OF FORM" "UNDEFINED FUNCTION" "CONTROL-E" 
"FLOATING UNDERFLOW" "FLOATING OVERFLOW" "OVERFLOW" "ARG NOT HARRAY" "TOO MANY ARGUMENTS"))
(DEFOPTIMIZER LISPERROR (MESSAGE ARG) (BQUOTE (\\LISPERROR (\\\, ARG) (\\\, (CL:IF (CL:STRINGP MESSAGE
) (FOR X IN \\ERRORMESSAGELIST AS I FROM 0 WHEN (CL:EQUAL X MESSAGE) DO (RETURN I) FINALLY (RETURN (
HELP "Unknown error message" (LIST MESSAGE ARG)))) MESSAGE)))))
(PUTPROP (QUOTE AERROR) (QUOTE IMPORTDATE) (IDATE "16-May-1990 11:58:35"))

(RECORD BASEBYTESTREAM STREAM (SUBRECORD STREAM) (ACCESSFNS ((BIASOFFST (|fetch| (STREAM FW6) |of| 
DATUM) (|replace| (STREAM FW6) |of| DATUM |with| NEWVALUE)) (BBSNCHARS (|fetch| (STREAM FW7) |of| 
DATUM) (|replace| (STREAM FW7) |of| DATUM |with| NEWVALUE)) (WRITEXTENSIONFN (|fetch| (STREAM F1) |of|
 DATUM) (|replace| (STREAM F1) |of| DATUM |with| NEWVALUE)))))
(PUTPROPS \\INSTREAMARG MACRO ((STRM NOERRORFLG) (\\GETSTREAM STRM (QUOTE INPUT) NOERRORFLG)))
(PUTPROPS \\OUTSTREAMARG MACRO ((STRM NOERRORFLG) (\\GETSTREAM STRM (QUOTE OUTPUT) NOERRORFLG)))
(PUTPROPS \\STREAMARG MACRO (OPENLAMBDA (STRM NOERRORFLG) (COND (NOERRORFLG (\\GETSTREAM STRM NIL T)) 
(T (\\DTEST STRM (QUOTE STREAM))))))
(PUTPROP (QUOTE AOFD) (QUOTE IMPORTDATE) (IDATE "13-Sep-1990 16:39:58"))

(PUTPROPS .SPACECHECK. MACRO ((STRM N) (AND \\THISFILELINELENGTH (IGREATERP (IPLUS N (|fetch| 
CHARPOSITION |of| STRM)) \\THISFILELINELENGTH) (FRESHLINE STRM))))
(PUTPROPS \\CHECKRADIX MACRO (LAMBDA (R) (COND ((OR (NOT (SMALLP R)) (ILESSP R 1) (IGREATERP R 36)) (
\\INVALID.RADIX R)) (T R))))
(PUTPROPS \\XCCSFILEOUTCHARFN MACRO ((OUTSTREAM CHARCODE) (* |;;;| 
"Encoder for XCCS format.  Default decoder.") (COND ((EQ CHARCODE (CHARCODE EOL)) (COND ((NOT (
\\RUNCODED OUTSTREAM)) (* \; "Charset is a constant 0") (\\BOUT OUTSTREAM (\\CHARSET (CHARCODE EOL))))
 ((EQ (\\CHARSET (CHARCODE EOL)) (|ffetch| (STREAM CHARSET) |of| OUTSTREAM))) (T (\\BOUT OUTSTREAM 
NSCHARSETSHIFT) (\\BOUT OUTSTREAM (|freplace| (STREAM CHARSET) |of| OUTSTREAM |with| (\\CHARSET (
CHARCODE EOL)))))) (\\BOUT OUTSTREAM (SELECTC (|ffetch| EOLCONVENTION |of| OUTSTREAM) (CR.EOLC (
CHARCODE CR)) (LF.EOLC (CHARCODE LF)) (CRLF.EOLC (\\BOUT OUTSTREAM (CHARCODE CR)) (* |;;| 
"Don't put out high-order byte preceding LF.  The CRLF is EOL only if the bytes are immediately adjacent in the stream, with no additional encoding bytes"
) (CHARCODE LF)) (SHOULDNT))) (|freplace| CHARPOSITION |of| OUTSTREAM |with| 0)) (T (COND ((NOT (
\\RUNCODED OUTSTREAM)) (\\BOUT OUTSTREAM (\\CHARSET CHARCODE)) (\\BOUT OUTSTREAM (\\CHAR8CODE CHARCODE
))) ((EQ (\\CHARSET CHARCODE) (|ffetch| (STREAM CHARSET) |of| OUTSTREAM)) (\\BOUT OUTSTREAM (
\\CHAR8CODE CHARCODE))) (T (\\BOUT OUTSTREAM NSCHARSETSHIFT) (\\BOUT OUTSTREAM (|freplace| (STREAM 
CHARSET) |of| OUTSTREAM |with| (\\CHARSET CHARCODE))) (\\BOUT OUTSTREAM (\\CHAR8CODE CHARCODE)))) (
|freplace| CHARPOSITION |of| OUTSTREAM |with| (PROGN (* \; "Ugh.  Don't overflow") (IPLUS16 (|ffetch| 
CHARPOSITION |of| OUTSTREAM) 1)))))))
(PUTPROP (QUOTE APRINT) (QUOTE IMPORTDATE) (IDATE "17-Jan-2020 05:51:20"))

(GLOBALVARS \\BCPLDISPLAY)
(ACCESSFNS LINEBUFFER ((LPARCOUNT (|fetch| FW6 |of| DATUM) (|replace| FW6 |of| DATUM |with| NEWVALUE))
 (LBRKCOUNT (|fetch| FW7 |of| DATUM) (|replace| FW7 |of| DATUM |with| NEWVALUE)) (LINEBUFSTATE (
|fetch| F5 |of| DATUM) (|replace| F5 |of| DATUM |with| NEWVALUE)) (* \; "F4 is free.  EJS, 7/8/85") (
KEYBOARDSTREAM (|fetch| F2 |of| DATUM) (|replace| F2 |of| DATUM |with| NEWVALUE)) (PEEKEDCHAR (|fetch|
 F3 |of| DATUM) (|replace| F3 |of| DATUM |with| NEWVALUE)) (* \; "Character read by PEEKC") (LBFLAGS (
|fetch| FW9 |of| DATUM) (|replace| FW9 |of| DATUM |with| NEWVALUE)) (* |;;| 
"True if peeked char was echoed when peeked.  Could use this to determine whether to echo later or not, but that would be incompatible with Interlisp-10, so this field not used"
)) (ACCESSFNS LINEBUFFER ((LBFLAGBASE (LOCF (|fetch| LBFLAGS |of| DATUM)))) (BLOCKRECORD LBFLAGBASE ((
PEEKEDECHOFLG FLAG) (INSTRINGP FLAG)))))
(RPAQQ LINEBUFFERSTATES (FILLING.LBS READING.LBS RETYPING.LBS))
(RPAQQ FILLING.LBS 0)
(RPAQQ READING.LBS 1)
(RPAQQ RETYPING.LBS 2)
(CONSTANTS FILLING.LBS READING.LBS RETYPING.LBS)
(PUTPROPS \\INTERMP MACRO ((OFD) (EQ OFD \\LINEBUF.OFD)))
(PUTPROPS \\OUTTERMP MACRO ((OFD) (EQ OFD \\TERM.OFD)))
(GLOBALVARS \\DEFAULTLINEBUF)
(PUTPROP (QUOTE ATERM) (QUOTE IMPORTDATE) (IDATE "16-May-1990 12:08:04"))

(DATATYPE HARRAYP ((NULLSLOTS WORD) (* \; "Number of NIL-NIL slots, which break chains") (LASTINDEX 
WORD) (* \; 
"Slot offset of last slot.  Used in probe computations computations.  Microcode support for \\ADDBASE4 would help"
) (HARRAYPBASE POINTER) (RECLAIMABLE FLAG) (* \; "True if keys can go away when no other refs") (
OVERFLOWACTION POINTER) (NUMSLOTS WORD) (* \; 
"The maximum number of logical slots--returned by HARRAYSIZE") (NUMKEYS WORD) (* \; 
"The number of distinct keys in the array") (HASHBITSFN POINTER) (EQUIVFN POINTER) (HASHUSERDATA 
POINTER)))
(PUTPROPS \\EQHASHINGBITS MACRO (OPENLAMBDA (X) (* \; 
"Spread out objects whose low bits are in small arithmetic progression, esp atoms") (LOGXOR (\\HILOC X
) (LOGXOR (LLSH (LOGAND (\\LOLOC X) 8191) 3) (LRSH (\\LOLOC X) 9)))))
(PUTPROPS \\ADDBASE2 MACRO (OPENLAMBDA (BASE N) (\\ADDBASE (\\ADDBASE BASE N) N)))
(PUTPROPS \\ADDBASE4 MACRO (OPENLAMBDA (BASE N) (\\ADDBASE2 (\\ADDBASE2 BASE N) N)))
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (|fetch| DTDSIZE |of| (\\GETDTD NTYPX)) 
WORDSPERCELL)))
(PUTPROPS \\BYTELT DMACRO (OPENLAMBDA (A J) (\\GETBASEBYTE (|fetch| (ARRAYP BASE) |of| A) (IPLUS (
|fetch| (ARRAYP OFFST) |of| A) J))))
(PUTPROPS \\BYTESETA DMACRO (OPENLAMBDA (A J V) (\\PUTBASEBYTE (|fetch| (ARRAYP BASE) |of| A) (IPLUS (
|fetch| (ARRAYP OFFST) |of| A) J) V)))
(PUTPROPS \\WORDELT DMACRO (OPENLAMBDA (A J) (CHECK (AND (ARRAYP A) (EQ 0 (|fetch| (ARRAYP ORIG) |of| 
A)) (EQ \\ST.POS16 (|fetch| (ARRAYP TYP) |of| A)))) (CHECK (IGREATERP (|fetch| (ARRAYP LENGTH) |of| A)
 J)) (\\GETBASE (|fetch| (ARRAYP BASE) |of| A) (IPLUS (|fetch| (ARRAYP OFFST) |of| A) J))))
(RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (UNBOXEDBLOCK.GCT 0)))
(RPAQQ CODEBLOCK.GCT 2)
(RPAQQ PTRBLOCK.GCT 1)
(RPAQQ UNBOXEDBLOCK.GCT 0)
(CONSTANTS (CODEBLOCK.GCT 2) (PTRBLOCK.GCT 1) (UNBOXEDBLOCK.GCT 0))
(RPAQQ ARRAYCONSTANTS (|\\ArrayBlockHeaderCells| |\\ArrayBlockHeaderWords| |\\ArrayBlockTrailerCells| 
|\\ArrayBlockTrailerWords| (|\\ArrayBlockOverheadCells| (IPLUS |\\ArrayBlockHeaderCells| 
|\\ArrayBlockTrailerCells|)) (|\\ArrayBlockOverheadWords| (IPLUS |\\ArrayBlockHeaderWords| 
|\\ArrayBlockTrailerWords|)) |\\ArrayBlockLinkingCells| (|\\MinArrayBlockSize| (IPLUS 
|\\ArrayBlockOverheadCells| |\\ArrayBlockLinkingCells|)) (|\\MaxArrayBlockSize| 65535) (
|\\MaxArrayNCells| (IDIFFERENCE |\\MaxArrayBlockSize| |\\ArrayBlockOverheadCells|)) |\\MaxArrayLen| (
\\ABPASSWORDSHIFT 3) (|\\ArrayBlockPassword| (LRSH 43690 \\ABPASSWORDSHIFT)) (|\\FreeArrayFlagWord| (
LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH UNBOXEDBLOCK.GCT 1))) (
|\\UsedArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) 1)) (
|\\CodeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT 1) 1)
)))
(RPAQQ |\\ArrayBlockHeaderCells| 1)
(RPAQQ |\\ArrayBlockHeaderWords| 2)
(RPAQQ |\\ArrayBlockTrailerCells| 1)
(RPAQQ |\\ArrayBlockTrailerWords| 2)
(RPAQ |\\ArrayBlockOverheadCells| (IPLUS |\\ArrayBlockHeaderCells| |\\ArrayBlockTrailerCells|))
(RPAQ |\\ArrayBlockOverheadWords| (IPLUS |\\ArrayBlockHeaderWords| |\\ArrayBlockTrailerWords|))
(RPAQQ |\\ArrayBlockLinkingCells| 2)
(RPAQ |\\MinArrayBlockSize| (IPLUS |\\ArrayBlockOverheadCells| |\\ArrayBlockLinkingCells|))
(RPAQQ |\\MaxArrayBlockSize| 65535)
(RPAQ |\\MaxArrayNCells| (IDIFFERENCE |\\MaxArrayBlockSize| |\\ArrayBlockOverheadCells|))
(RPAQQ |\\MaxArrayLen| 65535)
(RPAQQ \\ABPASSWORDSHIFT 3)
(RPAQ |\\ArrayBlockPassword| (LRSH 43690 \\ABPASSWORDSHIFT))
(RPAQ |\\FreeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH 
UNBOXEDBLOCK.GCT 1)))
(RPAQ |\\UsedArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) 1))
(RPAQ |\\CodeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT
 1) 1))
(CONSTANTS |\\ArrayBlockHeaderCells| |\\ArrayBlockHeaderWords| |\\ArrayBlockTrailerCells| 
|\\ArrayBlockTrailerWords| (|\\ArrayBlockOverheadCells| (IPLUS |\\ArrayBlockHeaderCells| 
|\\ArrayBlockTrailerCells|)) (|\\ArrayBlockOverheadWords| (IPLUS |\\ArrayBlockHeaderWords| 
|\\ArrayBlockTrailerWords|)) |\\ArrayBlockLinkingCells| (|\\MinArrayBlockSize| (IPLUS 
|\\ArrayBlockOverheadCells| |\\ArrayBlockLinkingCells|)) (|\\MaxArrayBlockSize| 65535) (
|\\MaxArrayNCells| (IDIFFERENCE |\\MaxArrayBlockSize| |\\ArrayBlockOverheadCells|)) |\\MaxArrayLen| (
\\ABPASSWORDSHIFT 3) (|\\ArrayBlockPassword| (LRSH 43690 \\ABPASSWORDSHIFT)) (|\\FreeArrayFlagWord| (
LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH UNBOXEDBLOCK.GCT 1))) (
|\\UsedArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) 1)) (
|\\CodeArrayFlagWord| (LOGOR (LLSH |\\ArrayBlockPassword| \\ABPASSWORDSHIFT) (LLSH CODEBLOCK.GCT 1) 1)
))
(RPAQQ ARRAYTYPES ((\\ST.BYTE 0) (\\ST.POS16 1) (\\ST.INT32 2) (\\ST.CODE 4) (\\ST.PTR 6) (\\ST.FLOAT 
7) (\\ST.BIT 8) (\\ST.PTR2 11)))
(RPAQQ \\ST.BYTE 0)
(RPAQQ \\ST.POS16 1)
(RPAQQ \\ST.INT32 2)
(RPAQQ \\ST.CODE 4)
(RPAQQ \\ST.PTR 6)
(RPAQQ \\ST.FLOAT 7)
(RPAQQ \\ST.BIT 8)
(RPAQQ \\ST.PTR2 11)
(CONSTANTS (\\ST.BYTE 0) (\\ST.POS16 1) (\\ST.INT32 2) (\\ST.CODE 4) (\\ST.PTR 6) (\\ST.FLOAT 7) (
\\ST.BIT 8) (\\ST.PTR2 11))
(RPAQQ \\MAX.CELLSPERHUNK 64)
(CONSTANTS \\MAX.CELLSPERHUNK)
(RPAQQ \\IN.MAKEINIT NIL)
(CONSTANTS (\\IN.MAKEINIT))
(BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1) (NIL BITS 1) (READONLY FLAG) (NIL BITS 1) (BASE POINTER
) (TYP BITS 4) (NIL BITS 4) (LENGTH BITS 24) (OFFST FIXP)))
(DATATYPE ARRAYP ((* |;;| "Describes an INTERLISP ARRAYP, as opposed to a CL array.") (ORIG BITS 1) (*
 \; "Origin, 0 or 1") (NIL BITS 1) (READONLY FLAG) (* \; "probably no READONLY arrays now") (NIL BITS 
1) (BASE POINTER) (TYP BITS 4) (* \; "Type of the contents") (NIL BITS 4) (LENGTH BITS 24) (* \; 
"Array's length") (OFFST FIXP) (* \; "Offset from BASE where the data really starts.")) (* |;;| 
"note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}"
))
(BLOCKRECORD ARRAYBLOCK ((PASSWORD BITS 13) (GCTYPE BITS 2) (* \; "Unboxed, Pointers, or Code") (INUSE
 FLAG) (ARLEN WORD) (FWD FULLXPOINTER) (* \; "Only when on free list") (BKWD FULLXPOINTER)) (
BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD) (* \; "Used for header and trailer"))) (ACCESSFNS ARRAYBLOCK ((
DAT (\\ADDBASE DATUM |\\ArrayBlockHeaderWords|)) (TRAILER (\\ADDBASE2 DATUM (IDIFFERENCE (|fetch| (
ARRAYBLOCK ARLEN) |of| DATUM) |\\ArrayBlockTrailerCells|))))) (TYPE? (AND (EQ 0 (NTYPX DATUM)) (IGEQ (
\\HILOC DATUM) |\\FirstArraySegment|))))
(GLOBALVARS |\\NxtArrayPage| \\FREEBLOCKBUCKETS \\HUNKING?)
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (|fetch| DTDSIZE |of| (\\GETDTD NTYPX)) 
WORDSPERCELL)))
(PUTPROP (QUOTE LLARRAYELT) (QUOTE IMPORTDATE) (IDATE "15-Sep-1994 11:08:59"))

(DEFOPTIMIZER PUTBASEPTRX (&REST ARGS) (CONS (QUOTE (OPENLAMBDA (DATUM OFFSET NEWVALUE) (
UNINTERRUPTABLY (\\PUTBASE DATUM OFFSET (LOGOR (LOGAND 61440 (\\GETBASE DATUM OFFSET)) (LOGAND (
\\HILOC NEWVALUE) 4095))) (\\PUTBASE DATUM (ADD1 OFFSET) (\\LOLOC NEWVALUE)) NEWVALUE))) ARGS))
(RPAQQ \\SMALLP 1)
(RPAQQ \\FIXP 2)
(RPAQQ \\FLOATP 3)
(RPAQQ \\LITATOM 4)
(RPAQQ \\LISTP 5)
(RPAQQ \\ARRAYP 6)
(RPAQQ \\STACKP 8)
(RPAQQ \\VMEMPAGEP 10)
(RPAQQ \\STREAM 11)
(RPAQQ \\NEW-ATOM 21)
(CONSTANTS \\SMALLP \\FIXP \\FLOATP \\LITATOM \\LISTP \\ARRAYP \\STACKP \\VMEMPAGEP \\STREAM 
\\NEW-ATOM)
(RPAQQ \\BUILT-IN-SYSTEM-TYPES ((SMALLP) (FIXP 2) (FLOATP 2) (LITATOM) (LISTP 4 (0 2)) (ARRAYP 6 (0)) 
(STRINGP 6 (0)) (STACKP 2 NIL \\RECLAIMSTACKP) (CHARACTER) (VMEMPAGEP 256 NIL RELEASINGVMEMPAGE) (
STREAM) (BITMAP) (COMPILED-CLOSURE 4 (0 2)) (ONED-ARRAY 8 (0)) (TWOD-ARRAY 10 (0)) (GENERAL-ARRAY 10 (
0 8)) (BIGNUM) (RATIO) (COMPLEX) (PATHNAME) (NEW-ATOM 10 (2 4 6)) (FILLER22) (FILLER23) (FILLER24) (
FILLER25) (FILLER26) (FILLER27) (FILLER28) (FILLER29) (FILLER30)))
(BLOCKRECORD DTD ((NIL BITS 2) (DTDOBSOLETE FLAG) (* \; 
"True for type of a redeclared datatype--not allowed to allocate more of these") (DTDFINALIZABLE FLAG)
 (* \; "True if finalization exists for this type") (DTDNAME POINTER) (* \; "Type name -- a symbol ") 
(DTDCNT0 WORD) (* \; "Incremental box count -- this plus DTDOLDCNT is the true box count") (DTDSIZE 
WORD) (* \; "Length of datum in words") (DTDFREE FULLXPOINTER) (* \; 
"Pointer to first object on free chain, or NIL.  Not used for LISTP") (DTDLOCKEDP FLAG) (* \; 
"True if objects of this type must be locked down (not pagefault)") (DTDHUNKP FLAG) (* \; 
"True if this type is used as an array hunk type") (DTDGCTYPE BITS 2) (* \; 
"For hunk datatypes, is analogous to arrayblock's GCTYPE") (DTDDESCRS POINTER) (DTDTYPESPECS POINTER) 
(DTDPTRS POINTER) (* \; 
"List of word offsets inside datum where reference-counted pointers are stored -- used by GC") (
DTDOLDCNT FIXP) (* \; "'Box count' -- number of objects of this type ever allocated") (DTDNEXTPAGE 
FIXP) (* \; 
"Currently only for LISTP pages -- page number of next page on chain of non-full cons pages") (
DTDTYPEENTRY WORD) (* |;;| 
"The word stored in the type table for objects of this type.  Hi bits have numberp tags, ref countable, etc."
) (DTDSUPERTYPE WORD) (* \; "Type number of immediate supertype, or zero if none")) (ACCESSFNS DTD ((
DTDCNTLOC (\\ADDBASE DATUM 4)) (DTDCNT (IPLUS (|fetch| DTDOLDCNT DATUM) (|fetch| DTDCNT0 DATUM)) (
UNINTERRUPTABLY (|replace| DTDOLDCNT |of| DATUM |with| NEWVALUE) (|replace| DTDCNT0 |of| DATUM |with| 
0))))))
(PUTPROPS \\GETDTD MACRO ((|typeNum|) (ADDBASE |\\DTDSpaceBase| (ITIMES |typeNum| 18))))
(DEFOPTIMIZER \\TYPEMASK.UFN (&REST X) (LET ((CE (CONSTANTEXPRESSIONP (CADR X)))) (|if| CE |then| (
BQUOTE ((OPCODES TYPEMASK.N (\\\, (CAR CE))) (\\\, (CAR X)))) |else| (QUOTE IGNOREMACRO))))
(RPAQQ \\GUARDSTORAGEFULL 128)
(RPAQQ \\GUARD1STORAGEFULL 64)
(CONSTANTS \\GUARDSTORAGEFULL \\GUARD1STORAGEFULL)
(GLOBALVARS |\\NxtMDSPage| |\\LeastMDSPage| |\\SecondArrayPage| |\\SecondMDSPage| \\MDSFREELISTPAGE 
|\\MaxSysTypeNum| |\\MaxTypeNumber| \\STORAGEFULL \\INTERRUPTSTATE \\PENDINGINTERRUPT)
(PUTPROP (QUOTE LLDATATYPE) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:57:50"))

(ACCESSFNS POINTER ((PAGE# (IPLUS (LLSH (\\HILOC DATUM) 8) (LRSH (\\LOLOC DATUM) 8))) (WORDINPAGE (
LOGAND (\\LOLOC DATUM) 255)) (CELLINPAGE (LRSH (|fetch| WORDINPAGE |of| DATUM) 1)) (BYTEINPAGE (LLSH (
|fetch| WORDINPAGE |of| DATUM) 1)) (SEGMENT# (\\HILOC DATUM)) (WORDINSEGMENT (\\LOLOC DATUM)) (
CELLINSEGMENT (LRSH (|fetch| WORDINSEGMENT |of| DATUM) 1)) (WORD# (|fetch| WORDINPAGE |of| DATUM)) (
DBLWORD# (|fetch| CELLINPAGE |of| DATUM)) (PAGEBASE (\\VAG2 (\\HILOC DATUM) (LOGAND (\\LOLOC DATUM) 
65280)))) (CREATE (\\VAG2 (LRSH PAGE# 8) (LLSH (LOGAND PAGE# 255) 8))))
(ACCESSFNS WORD ((HIBYTE (LRSH DATUM 8)) (LOBYTE (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH HIBYTE 8) 
LOBYTE)))
(PUTPROPS PTRGTP MACRO (OPENLAMBDA (X Y) (OR (IGREATERP (\\HILOC X) (\\HILOC Y)) (AND (EQ (\\HILOC X) 
(\\HILOC Y)) (IGREATERP (\\LOLOC X) (\\LOLOC Y))))))
(PUTPROPS .COERCE.TO.SMALLPOSP. DMACRO (OPENLAMBDA (X) (COND ((SMALLPOSP X) X) (T (\\ILLEGAL.ARG X))))
)
(PUTPROPS .COERCE.TO.BYTE. DMACRO (OPENLAMBDA (X) (COND ((AND (SMALLPOSP X) (ILESSP X (CONSTANT (LLSH 
1 BITSPERBYTE)))) X) (T (\\ILLEGAL.ARG X)))))
(BLOCKRECORD LISTP ((* |;;| "Describes a CONS cell.") (CAR POINTER) (CDR POINTER)) (CREATE (CREATECELL
 \\LISTP)) (* |;;| "FOLLOWING ARE CDR-CODE FIELDS") (BLOCKRECORD LISTP ((CDRCODE BITS 4) (CARFIELD 
XPOINTER))) (* |;;| "For chaining together free cells on a page:") (BLOCKRECORD LISTP ((NEXTFREE BYTE)
 (NIL BITS 24))) (ACCESSFNS LISTP ((FULLCARFIELD NIL (\\PUTBASEPTR DATUM 0 NEWVALUE)))) (* |;;| 
"because replace of XPOINTER is slow, the CAR field is stored with PUTBASEPTR, even though that smashes the hi byte"
))
(BLOCKRECORD CONSPAGE ((* |;;| 
"Describes a page of CONS cells, which (when free) are chained together thru the top byte.") (NIL 2 
FIXP) (* \; "Empty cells, space for another 2 CONS cells if we can figure out how.") (CNT BYTE) (* \; 
"# of cells free on this page") (NEXTCELL BYTE) (* \; 
"WORD offset of next free cell (not guaranteed to be 0 if no free cells)") (NIL WORD) (* \; "Padding")
 (NEXTPAGE FIXP) (* \; "Next CONS page on the DTD's free list, for searching for cells.")))
(RPAQQ CONSCONSTANTS (\\CDR.ONPAGE \\CDR.NIL \\CDR.INDIRECT \\CDR.MAXINDIRECT \\CONSPAGE.LAST))
(RPAQQ \\CDR.ONPAGE 8)
(RPAQQ \\CDR.NIL 8)
(RPAQQ \\CDR.INDIRECT 0)
(RPAQQ \\CDR.MAXINDIRECT 7)
(RPAQQ \\CONSPAGE.LAST 65535)
(CONSTANTS \\CDR.ONPAGE \\CDR.NIL \\CDR.INDIRECT \\CDR.MAXINDIRECT \\CONSPAGE.LAST)
(PUTPROPS LOCAL MACRO ((X) X))
(PUTPROPS ALLOCAL MACRO ((X) X))
(PUTPROP (QUOTE LLNEW) (QUOTE IMPORTDATE) (IDATE " 2-Feb-1995 16:21:44"))

(PUTPROPS CHECK MACRO (ARGS (COND ((AND (BOUNDP (QUOTE CHECK)) CHECK) (CONS (QUOTE PROGN) (|for| I 
|in| ARGS |collect| (LIST (QUOTE OR) I (LIST (QUOTE RAID) (KWOTE (LIST (QUOTE |Check-failure:|) I)))))
)) (T (CONS COMMENTFLG ARGS)))))
(PUTPROPS |\\StatsZero| BYTEMACRO (OPENLAMBDA (N) (\\PUTBASE N 0 0) (\\PUTBASE N 1 0)))
(PUTPROPS |\\StatsAdd1| DMACRO (OPENLAMBDA (A) (PROG ((LO (IPLUS16 (\\GETBASE A 1) 1))) (DECLARE (
LOCALVARS LO)) (* \; "Increment double word at A by 1") (\\PUTBASE A 1 LO) (COND ((EQ LO 0) (\\PUTBASE
 A 0 (ADD1 (\\GETBASE A 0))))))))
(PUTPROPS IPLUS16 MACRO ((X Y) (* \; "Kludge to do 16-bit plus") (\\LOLOC (\\ADDBASE X Y))))
(PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0))))
(PROGN (PUTPROPS SETXVAR MACRO (X (BQUOTE (SETQ.NOREF \, (CADAR X) \, (CADR X))))) (PUTPROPS SETXVAR 
DMACRO (X (OR (AND (EQ (CAAR X) (QUOTE QUOTE)) (LITATOM (CADAR X))) (SHOULDNT)) (GLOBALVARS \\VALSPACE
) (LIST (QUOTE SETQ.NOREF) (CADAR X) (CADR X)))))
(PUTPROPS SETQ.NOREF DMACRO ((VAR VAL) (\\PUTBASEPTR (LOCF (|fetch| (LITATOM VALUE) |of| (QUOTE VAR)))
 0 VAL)))
(PROGN (PUTPROPS IEQ MACRO ((X Y) (IEQP X Y))) (PUTPROPS IEQ DMACRO (= . EQ)))
(RPAQQ |WordsPerPage| 256)
(CONSTANTS |WordsPerPage|)
(ACCESSFNS LITATOM ((DEFINITIONCELL (\\DEFCELL DATUM)) (PROPCELL (\\PROPCELL DATUM)) (VCELL (\\VALCELL
 DATUM)) (PNAMECELL (\\PNAMECELL DATUM))) (* |;;| 
"VCELL can also be accessed directly from a value index via the record VALINDEX (as in \\SETGLOBALVAL.UFN) --- Similarly, PNAMEINDEX accesses PNAMECELL for use by \\MKATOM and UNCOPYATOM"
) (TYPE? (LITATOM DATUM)) (BLOCKRECORD PROPCELL ((NIL BITS 4) (* \; "former flags locations") (
PROPLIST POINTER) (NIL BITS 8) (* \; "Package byte") (NIL BITS 8) (* \; "Flags from defcell") (* |;;| 
"PROPCell flags:") (NIL BITS 1) (GENSYMP FLAG) (FATPNAMEP FLAG) (NIL BITS 5) (* |;;| 
"Filler for final cell:") (NIL BITS 8))))
(SYNONYM CL:SYMBOL (LITATOM))
(ACCESSFNS VALINDEX ((VCELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* \; 
"Xerox Lisp traditional symbol") (\\ADDBASE2 \\PNPSPACE (IPLUS \\NEWATOM-VALOFFSET (ITIMES 10 DATUM)))
) (T (* \; "New symbol") (* \; "'90/07/19 ON") (\\ADDBASE DATUM \\NEWATOM-VALOFFSET))))))
(BLOCKRECORD VCELL ((VALUE FULLPOINTER)))
(BLOCKRECORD DEFINITIONCELL ((CCODEP FLAG) (FASTP FLAG) (ARGTYPE BITS 2) (* \; "Former flag location")
 (DEFPOINTER POINTER) (NIL POINTER) (* \; "Proplist cell") (NIL BITS 8) (* \; "package") (* |;;| 
"DEFCELL flags overflow from top 4 bits of the real cell:") (NIL BITS 4) (PSEUDOCODEP FLAG) (NIL BITS 
3) (* |;;| "proplist falgs and filler:") (NIL BITS 16)) (BLOCKRECORD DEFINITIONCELL ((DEFCELLFLAGS 
BITS 4) (NIL POINTER) (* \; "defn ptr") (NIL BITS 4) (NIL POINTER) (* \; "filler for proplist ptr") (
NIL BITS 8) (AUXDEFCELLFLAGS BYTE) (NIL BITS 16))))
(BLOCKRECORD FNHEADER ((STKMIN WORD) (NA SIGNEDWORD) (PV SIGNEDWORD) (STARTPC WORD) (CLOSUREP FLAG) (*
 \; "T if this is a \"compiled closure\"") (BYTESWAPPED FLAG) (* \; 
"T if, on 386, we reswapped the code section of this function for faster access.") (ARGTYPE BITS 2) (*
 \; "0 = LAMBDA") (* \; "2 = LAMBDA nospread") (* \; "1 = NLAMBDA") (* \; "3 = NLAMBDA nospread") (* 
|;;| "4 NIL BITS USED TO BE HERE.") (\#FRAMENAME XPOINTER) (NTSIZE WORD) (* \; 
"Size of the Name Table, IN WORDS.  This value is always rounded up to the next Quad-word in size, and there' guaranteed to be one entry of zeros in the length."
) (NLOCALS BYTE) (FVAROFFSET BYTE)) (ACCESSFNS FNHEADER ((LSTARP (ILESSP (|fetch| (FNHEADER NA) |of| 
DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (NATIVE (PROGN NIL)) (* \; 
"T if this is a NATIVE-code function (never true!)") (ALIGNED (IPLUS (|fetch| (FNHEADER NTSIZE) |of| 
DATUM) (|fetch| (FNHEADER OVERHEADWORDS) |of| T))) (FIXED NIL (|replace| (FNHEADER STKMIN) |of| DATUM 
|with| (\\STKMIN DATUM T))) (NPVARWORDS (UNFOLD (ADD1 (|fetch| (FNHEADER PV) |of| DATUM)) WORDSPERQUAD
)) (FRAMENAME (|fetch| (FNHEADER \#FRAMENAME) |of| DATUM) (UNINTERRUPTABLY (CHECK (NEQ (\\HILOC DATUM)
 \\STACKHI)) (\\DELREF (|fetch| (FNHEADER \#FRAMENAME) |of| DATUM)) (\\ADDREF NEWVALUE) (|replace| (
FNHEADER \#FRAMENAME) |of| DATUM |with| NEWVALUE))))))
(BLOCKRECORD PNAMECELL ((NIL BITS 4) (PNAMEBASE XPOINTER) (NIL POINTER) (* \; "val, def, prop cells") 
(NIL POINTER) (NIL POINTER) (PACKAGEINDEX BYTE) (NIL BITS 24) (* \; "filler for other flags")) (
BLOCKRECORD PNAMECELL ((FULLPNAMEBASE FULLXPOINTER) (* \; "Replacing this smashes PACKAGEINDEX to 0"))
) (ACCESSFNS PNAMECELL ((PACKAGE (LET ((I (FETCH (PNAMECELL PACKAGEINDEX) OF DATUM))) (* \; 
"This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound."
) (COND ((EQ 0 I) NIL) (T (CL:AREF *PACKAGE-FROM-INDEX* I)))) (REPLACE (PNAMECELL PACKAGEINDEX) OF 
DATUM WITH (IF (NULL NEWVALUE) THEN *UNINTERNED-PACKAGE-INDEX* ELSE (CL::%PACKAGE-INDEX NEWVALUE))))))
)
(ACCESSFNS PACKAGEINDEX ((PACKAGE (IF (EQ 0 DATUM) (* \; 
"This ugly construct allows cl:symbol-package to run in the init, where *PACKAGE-FROM-INDEX* is not yet bound."
) THEN NIL ELSE (CL:AREF *PACKAGE-FROM-INDEX* DATUM)))))
(BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE) (* \; "Length is always here, be the pname thin or fat") (
PNAMEFATPADDINGBYTE BYTE) (* \; 
"This byte is zero for fat pnames so that the pname chars are word-aligned")))
(ACCESSFNS PNAMEINDEX ((PNAMECELL (COND ((AND (FIXP DATUM) (ILESSP DATUM 65535)) (* \; 
"Xerox Lisp traditional symbol") (\\ADDBASE \\OLDATOMSPACE (IPLUS \\NEWATOM-PNAMEOFFSET (ITIMES 10 
DATUM)))) (T (* \; "New symbol") (* \; "'90/07/19 ON") (\\ADDBASE DATUM \\NEWATOM-PNAMEOFFSET))))))
(BLOCKRECORD NEW-ATOM ((* |;;| 
"An extended symbol, for expanding atom space.  Kept in its own datatype.") (PNAME XPOINTER) (* \; 
"PNAME, same as litatom.") (VALUE POINTER) (DEF POINTER) (PROPLIST POINTER) (* |;;| 
"Flags that used to be above the pointers, e.g. package, ccodep, gensymp:") (NIL BITS 32)))
(PUTPROPS \\DEFCELL MACRO ((ATOM) (\\ATOMCELL ATOM \\DEF.HI)))
(PUTPROPS \\VALCELL MACRO ((ATOM) (\\ATOMCELL ATOM \\VAL.HI)))
(PUTPROPS \\PNAMECELL MACRO ((ATOM) (\\ATOMCELL ATOM \\PNAME.HI)))
(PUTPROPS \\ATOMVALINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; 
"Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (
SHOULDNT)))))
(PUTPROPS \\ATOMDEFINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; 
"Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (
SHOULDNT)))))
(PUTPROPS \\ATOMPNAMEINDEX DMACRO (OPENLAMBDA (X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; 
"Original litatoms") (\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (
SHOULDNT)))))
(PUTPROPS \\ATOMPROPINDEX DMACRO ((X) (COND ((EQ (NTYPX X) \\LITATOM) (* \; "Original litatoms") (
\\LOLOC X)) ((EQ (NTYPX X) \\NEW-ATOM) (* \; "new 3-byte symbols") X) (T (SHOULDNT)))))
(PUTPROPS \\INDEXATOMPNAME DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; 
"Xerox Lisp traditional symbol") (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (
LOGAND X 65535))))) (T (* \; "New symbol") X))))
(PUTPROPS \\INDEXATOMVAL DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol")
 (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* \; 
"New symbol") X))))
(PUTPROPS \\INDEXATOMDEF DMACRO (OPENLAMBDA (X) (COND ((FIXP X) (* \; "Xerox Lisp traditional symbol")
 (COND ((SMALLP X) (\\VAG2 |\\AtomHI| X)) (T (\\VAG2 (LRSH X 16) (LOGAND X 65535))))) (T (* \; 
"New symbol") X))))
(PUTPROPS \\ATOMNUMBER DMACRO (= . \\LOLOC))
(GLOBALVARS |\\NxtPnByte| |\\CurPnPage| |\\NxtAtomPage| |\\AtomFrLst| |\\OneCharAtomBase| 
\\PNAMES.IN.BLOCKS? \\SCRATCHSTRING COMPILEATPUTDFLG)
(RPAQQ \\PNAMELIMIT 255)
(RPAQQ |\\CharsPerPnPage| 512)
(CONSTANTS (\\PNAMELIMIT 255) (|\\CharsPerPnPage| 512))
(RPAQQ \\NEWATOM-PNAMEOFFSET 0)
(RPAQQ \\NEWATOM-VALOFFSET 2)
(RPAQQ \\NEWATOM-DEFOFFSET 4)
(RPAQQ \\NEWATOM-PLISTOFFSET 6)
(RPAQQ \\NEWATOM-TYPE# 21)
(CONSTANTS (\\NEWATOM-PNAMEOFFSET 0) (\\NEWATOM-VALOFFSET 2) (\\NEWATOM-DEFOFFSET 4) (
\\NEWATOM-PLISTOFFSET 6) (\\NEWATOM-TYPE# 21))
(PUTPROPS \\MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) (\\BLT (\\ADDBASE DBASE 
DOFFSET) (\\ADDBASE SBASE SOFFSET) NWORDS)))
(PUTPROP (QUOTE LLBASIC) (QUOTE IMPORTDATE) (IDATE "31-Jan-1998 09:55:50"))

(ACCESSFNS STRINGP ((XREADONLY (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| DATUM) (|replace| (
ARRAY-HEADER READ-ONLY-P) |of| DATUM |with| NEWVALUE)) (XBASE ((OPENLAMBDA (STRING) (COND ((|fetch| (
ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-BASE STRING)) (T (|fetch| (ARRAY-HEADER BASE) |of| 
STRING)))) DATUM) ((OPENLAMBDA (STRING NV) (|replace| (ARRAY-HEADER INDIRECT-P) |of| STRING |with| NIL
) (|replace| (ARRAY-HEADER BASE) |of| STRING |with| NV) NV) DATUM NEWVALUE)) (TYP ((OPENLAMBDA (STRING
) (SELECTC (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-TYPE-NUMBER STRING)) (T (
|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| STRING))) (%THIN-CHAR-TYPENUMBER \\ST.BYTE) (
%FAT-CHAR-TYPENUMBER \\ST.POS16) (SHOULDNT "Unknown type-number"))) DATUM) ((OPENLAMBDA (STRING NV) (
LET ((%NEW-TYPE-NUMBER (SELECTC NV (\\ST.BYTE %THIN-CHAR-TYPENUMBER) (\\ST.POS16 %FAT-CHAR-TYPENUMBER)
 (SHOULDNT "Unknown typ value")))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (
%SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| STRING 
|with| %NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (LENGTH (|fetch| (ARRAY-HEADER FILL-POINTER) |of| DATUM)
 ((OPENLAMBDA (STRING NV) (|replace| (ARRAY-HEADER FILL-POINTER) |of| STRING |with| NV) (|replace| (
ARRAY-HEADER TOTAL-SIZE) |of| STRING |with| NV) (COND ((%GENERAL-ARRAY-P STRING) (|freplace| (
GENERAL-ARRAY DIMS) |of| STRING |with| (LIST NV)))) NV) DATUM NEWVALUE)) (OFFST ((OPENLAMBDA (STRING) 
(COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (%ARRAY-OFFSET STRING)) (T (|fetch| (
ARRAY-HEADER OFFSET) |of| STRING)))) DATUM) ((OPENLAMBDA (STRING NV) (COND ((NOT (EQ 0 NV)) (|replace|
 (ARRAY-HEADER DISPLACED-P) |of| STRING |with| T))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| 
STRING) (%SET-ARRAY-OFFSET STRING NV)) (T (|replace| (ARRAY-HEADER OFFSET) |of| STRING |with| NV)))) 
DATUM NEWVALUE)) (* |;;| "The rest of these fields only appear when smashing") (XFLAGS (LOGAND (
|fetch| (ARRAY-HEADER FLAGS) |of| DATUM) 15) ((OPENLAMBDA (STRING) (|replace| (ARRAY-HEADER 
ADJUSTABLE-P) |of| STRING |with| NIL) (|replace| (ARRAY-HEADER DISPLACED-P) |of| STRING |with| NIL) (
|replace| (ARRAY-HEADER FILL-POINTER-P) |of| STRING |with| NIL) (|replace| (ARRAY-HEADER EXTENDABLE-P)
 |of| STRING |with| NIL)) DATUM))) (ACCESSFNS STRINGP ((ORIG ((OPENLAMBDA (STRING) 1) DATUM) ((
OPENLAMBDA (STRING NV) (COND ((NOT (EQ NV 1)) (ERROR "Il:stringp's are always origin 1"))) NV) DATUM 
NEWVALUE)) (* \; "An inoperative field") (SUBSTRINGED ((OPENLAMBDA (STRING) NIL) DATUM) ((OPENLAMBDA (
STRING NV) (OR (NULL NV) (ERROR "Substringed field not supported"))) DATUM NEWVALUE)) (READONLY (
|ffetch| (STRINGP XREADONLY) |of| DATUM) (|freplace| (STRINGP XREADONLY) |of| DATUM |with| NEWVALUE)) 
(FATSTRINGP ((OPENLAMBDA (STRING) (EQ (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (
%ARRAY-TYPE-NUMBER STRING)) (T (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| STRING))) %FAT-CHAR-TYPENUMBER
)) DATUM) ((OPENLAMBDA (STRING NV) (LET ((%NEW-TYPE-NUMBER (COND (NV %FAT-CHAR-TYPENUMBER) (T 
%THIN-CHAR-TYPENUMBER)))) (COND ((|fetch| (ARRAY-HEADER INDIRECT-P) |of| STRING) (
%SET-ARRAY-TYPE-NUMBER STRING %NEW-TYPE-NUMBER)) (T (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| STRING 
|with| %NEW-TYPE-NUMBER))))) DATUM NEWVALUE)) (BASE (|ffetch| (STRINGP XBASE) |of| DATUM) (|freplace| 
(STRINGP XBASE) |of| DATUM |with| NEWVALUE)))) (CREATE (|create| ONED-ARRAY BASE _ XBASE READ-ONLY-P _
 XREADONLY STRING-P _ T DISPLACED-P _ (NOT (EQ OFFST 0)) TYPE-NUMBER _ (COND ((EQ TYP \\ST.POS16) 
%FAT-CHAR-TYPENUMBER) (T %THIN-CHAR-TYPENUMBER)) OFFSET _ OFFST FILL-POINTER _ LENGTH TOTAL-SIZE _ 
LENGTH)) (TYPE? (CL:STRINGP DATUM)) OFFST _ 0 TYP _ \\ST.BYTE LENGTH _ 0)
(GLOBALVARS |\\OneCharAtomBase|)
(PUTDEF (QUOTE \\NUMSTR) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING 128))))
(PUTDEF (QUOTE \\NUMSTR1) (QUOTE RESOURCES) (QUOTE (NEW (CONCAT))))
(PUTDEF (QUOTE \\PNAMESTRING) (QUOTE RESOURCES) (QUOTE (NEW (ALLOCSTRING \\PNAMELIMIT NIL NIL 
\\FATPNAMESTRINGP))))
(RPAQQ \\FATPNAMESTRINGP T)
(CONSTANTS (\\FATPNAMESTRINGP T))
(PUTPROPS \\PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* \; 
"For stuffing chars into resource \\PNAMESTRING") (\\PUTBASECHAR \\FATPNAMESTRINGP BASE OFFSET CODE)))
(DEFOPTIMIZER FCHARACTER (NUM) (BQUOTE ((OPENLAMBDA (N) (COND ((IGREATERP N \\MAXTHINCHAR) (* \; 
"The character we're getting is NOT a thin character -- do it the hard way") (CHARACTER N)) ((
IGREATERP N (CHARCODE 9)) (\\ADDBASE |\\OneCharAtomBase| (IDIFFERENCE N 10))) ((IGEQ N (CHARCODE 0)) (
IDIFFERENCE N (CHARCODE 0))) (T (* \; "The common case -- just add on the one-atom base.") (\\ADDBASE 
|\\OneCharAtomBase| N)))) (\\\, NUM))))
(I.S.OPR (QUOTE |inpname|) NIL (QUOTE (SUBPAIR (QUOTE ($$END $$BODY $$FATP $$BASE $$OFFSET)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (BQUOTE (|bind| $$OFFSET _ 0 
$$BODY _ BODY $$BASE $$END $$FATP |declare| (LOCALVARS $$END $$BODY $$FATP $$BASE $$OFFSET) |first| (
PROG NIL $$RETRY (COND ((STRINGP $$BODY) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ 
$$OFFSET (SUB1 (|ffetch| (STRINGP OFFST) |of| $$BODY))) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP
 LENGTH) |of| $$BODY))) (SETQ $$FATP (|ffetch| (STRINGP FATSTRINGP) |of| $$BODY))) ((LITATOM $$BODY) (
SETQ $$BASE (|ffetch| (LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) 
|of| $$BASE)) (SETQ $$FATP (|ffetch| (LITATOM FATPNAMEP) |of| $$BODY))) (T (SETQ $$BODY (MKSTRING 
$$BODY)) (GO $$RETRY)))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (
GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET)
))))))) T)
(I.S.OPR (QUOTE |inatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END $$FATP)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 
$$BODY _ BODY $$BASE $$END $$FATP |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END $$FATP) |first| (
SETQ $$BASE (|ffetch| (LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) 
|of| $$BASE)) (SETQ $$FATP (|ffetch| (LITATOM FATPNAMEP) |of| $$BODY)) |eachtime| (SETQ $$OFFSET (ADD1
 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE 
$$OFFSET)) (T (\\GETBASETHIN $$BASE $$OFFSET)))))))) T)
(I.S.OPR (QUOTE |instring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE $$FATP)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY 
$$END $$OFFSET $$BASE $$FATP |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE $$FATP) |first| (SETQ 
$$OFFSET (SUB1 (|ffetch| (STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| 
$$BODY)) (SETQ $$END (IPLUS $$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) (SETQ $$FATP (|ffetch| 
(STRINGP FATSTRINGP) |of| $$BODY)) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET
 $$END) (GO $$OUT)) (SETQ I.V. (COND ($$FATP (\\GETBASEFAT $$BASE $$OFFSET)) (T (\\GETBASETHIN $$BASE 
$$OFFSET)))))))) T)
(I.S.OPR (QUOTE |infatatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY 
$$BASE $$END |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END) |first| (SETQ $$BASE (|ffetch| (
LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) 
|eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (
\\GETBASEFAT $$BASE $$OFFSET)))))) T)
(I.S.OPR (QUOTE |inthinatom|) NIL (QUOTE (SUBPAIR (QUOTE ($$OFFSET $$BODY $$BASE $$END)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$OFFSET _ 0 $$BODY _ BODY 
$$BASE $$END |declare| (LOCALVARS $$OFFSET $$BODY $$BASE $$END) |first| (SETQ $$BASE (|ffetch| (
LITATOM PNAMEBASE) |of| $$BODY)) (SETQ $$END (|ffetch| (PNAMEBASE PNAMELENGTH) |of| $$BASE)) 
|eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (
\\GETBASETHIN $$BASE $$OFFSET)))))) T)
(I.S.OPR (QUOTE |infatstring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET 
$$BASE |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE) |first| (SETQ $$OFFSET (SUB1 (|ffetch| (
STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS 
$$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (
IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\\GETBASEFAT $$BASE $$OFFSET)))))) T)
(I.S.OPR (QUOTE |inthinstring|) NIL (QUOTE (SUBPAIR (QUOTE ($$BODY $$END $$OFFSET $$BASE)) (LIST (
GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) (QUOTE (|bind| $$BODY _ BODY $$END $$OFFSET 
$$BASE |declare| (LOCALVARS $$BODY $$END $$OFFSET $$BASE) |first| (SETQ $$OFFSET (SUB1 (|ffetch| (
STRINGP OFFST) |of| $$BODY))) (SETQ $$BASE (|ffetch| (STRINGP BASE) |of| $$BODY)) (SETQ $$END (IPLUS 
$$OFFSET (|ffetch| (STRINGP LENGTH) |of| $$BODY))) |eachtime| (SETQ $$OFFSET (ADD1 $$OFFSET)) (AND (
IGREATERP $$OFFSET $$END) (GO $$OUT)) (SETQ I.V. (\\GETBASETHIN $$BASE $$OFFSET)))))) T)
(PUTPROPS \\CHARCODEP DMACRO (OPENLAMBDA (X) (* \; 
"used to also say (ILEQ X \\MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X)
 (IGEQ X 0))))
(PUTPROPS \\FATCHARCODEP DMACRO (OPENLAMBDA (X) (* \; 
"Used to also say (ILEQ X \\MAXFATCHAR), but that's implied by the first two clauses") (AND (SMALLP X)
 (IGREATERP X \\MAXTHINCHAR))))
(PUTPROPS \\THINCHARCODEP DMACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0) (ILEQ X \\MAXTHINCHAR))))
(PUTPROPS \\GETBASEFAT MACRO (= . \\GETBASE))
(PUTPROPS \\GETBASETHIN MACRO (= . \\GETBASEBYTE))
(PUTPROPS \\PUTBASEFAT MACRO (= . \\PUTBASE))
(PUTPROPS \\PUTBASETHIN MACRO (= . \\PUTBASEBYTE))
(PUTPROPS \\PUTBASECHAR MACRO (OPENLAMBDA (FATP BASE OFFSET CODE) (COND (FATP (\\PUTBASEFAT BASE 
OFFSET CODE)) (T (\\PUTBASETHIN BASE OFFSET CODE)))))
(PUTPROPS \\GETBASECHAR MACRO ((FATP BASE N) (COND (FATP (\\GETBASEFAT BASE N)) (T (\\GETBASETHIN BASE
 N)))))
(PUTPROPS \\CHARSET MACRO ((CHARCODE) (LRSH CHARCODE 8)))
(PUTPROPS \\CHAR8CODE MACRO ((CHARCODE) (LOGAND CHARCODE 255)))
(RPAQQ \\CHARMASK 255)
(RPAQQ \\MAXCHAR 255)
(RPAQQ \\MAXTHINCHAR 255)
(RPAQQ \\MAXFATCHAR 65535)
(RPAQQ \\MAXCHARSET 255)
(RPAQQ NSCHARSETSHIFT 255)
(RPAQQ \#STRINGPWORDS 4)
(CONSTANTS (\\CHARMASK 255) (\\MAXCHAR 255) (\\MAXTHINCHAR 255) (\\MAXFATCHAR 65535) (\\MAXCHARSET 255
) (NSCHARSETSHIFT 255) (\#STRINGPWORDS 4))
(PUTPROPS \\NATOMCHARS DMACRO ((AT) (|fetch| (LITATOM PNAMELENGTH) |of| AT)))
(PUTPROPS \\NSTRINGCHARS DMACRO ((S) (|fetch| (STRINGP LENGTH) |of| S)))
(PUTPROP (QUOTE LLCHAR) (QUOTE IMPORTDATE) (IDATE "11-Nov-2018 13:08:04"))

(ACCESSFNS BF ((BFBLOCK (ADDSTACKBASE DATUM))) (* \; "basic frame pointer") (BLOCKRECORD BFBLOCK ((
FLAGS BITS 3) (NIL BITS 3) (RESIDUAL FLAG) (* \; "true if this is not a full BF") (PADDING BITS 1) (
USECNT BITS 8) (IVAR WORD))) (TYPE? (IEQ (|fetch| (BF FLAGS) |of| DATUM) \\STK.BF)) (ACCESSFNS BF ((
NARGS (IDIFFERENCE (FOLDLO (IDIFFERENCE DATUM (|fetch| (BF IVAR) |of| DATUM)) WORDSPERCELL) (|fetch| (
BF PADDING) |of| DATUM))) (SIZE (IPLUS 2 (IDIFFERENCE DATUM (|fetch| (BF IVAR) |of| DATUM)))) (CHECKED
 (AND (|type?| BF DATUM) (|for| I |from| (|fetch| (BF IVAR) |of| DATUM) |to| (IDIFFERENCE DATUM 2) 
|by| 2 |always| (IEQ \\STK.NOTFLAG (|fetch| (BF FLAGS) |of| I))))))))
(ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* \; "frame extension index") (BLOCKRECORD FXBLOCK ((
FLAGS BITS 3) (* \; "= \\STK.FX") (FAST FLAG) (NIL FLAG) (INCALL FLAG) (* \; 
"set when fncall microcode has to punt") (VALIDNAMETABLE FLAG) (* \; 
"if on, NAMETABLE field is filled in.  If off, is same as FNHEADER") (NOPUSH FLAG) (* \; 
"when returning to this frame, don't push a value.  Set by interrupt code") (USECNT BITS 8) (\#ALINK 
WORD) (* \; "low bit is SLOWP") (FNHEADER FULLXPOINTER) (NEXTBLOCK WORD) (PC WORD) (NAMETABLE# 
FULLXPOINTER) (\#BLINK WORD) (\#CLINK WORD))) (BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE) (NIL BYTE) (NIL 
BITS 15) (* \; "most of the bits of #ALINK") (SLOWP FLAG) (* \; 
"if on, then BLINK and CLINK fields are valid.  If off, they are implicit") (NIL FULLXPOINTER 2) (
NAMETABHI WORD) (NAMETABLO WORD))) (TYPE? (IEQ (|fetch| (FX FLAGS) |of| DATUM) \\STK.FX)) (ACCESSFNS 
FX ((NAMETABLE (COND ((|fetch| (FX VALIDNAMETABLE) |of| DATUM) (|fetch| (FX NAMETABLE#) |of| DATUM)) (
T (|fetch| (FX FNHEADER) |of| DATUM))) (PROGN (|replace| (FX FAST) |of| DATUM |with| NIL) (|replace| (
FX NAMETABLE#) |of| DATUM |with| NEWVALUE) (|replace| (FX VALIDNAMETABLE) |of| DATUM |with| T))) (
FRAMENAME (|fetch| (FNHEADER FRAMENAME) |of| (|fetch| (FX NAMETABLE) |of| DATUM))) (INVALIDP (EQ DATUM
 0)) (* \; "true when A/CLink points at nobody, i.e. FX is bottom of stack") (FASTP (NOT (|fetch| (FX 
SLOWP) |of| DATUM)) (PROGN (CHECK (NULL NEWVALUE)) (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (
FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX \#CLINK) |of| DATUM 
|with| (|fetch| (FX \#ALINK) |of| DATUM)) (|replace| (FX SLOWP) |of| DATUM |with| T))))) (BLINK (COND 
((|fetch| (FX FASTP) |of| DATUM) (|fetch| (FX DUMMYBF) |of| DATUM)) (T (|fetch| (FX \#BLINK) |of| 
DATUM))) (PROGN (|replace| (FX \#BLINK) |of| DATUM |with| NEWVALUE) (COND ((|fetch| (FX FASTP) |of| 
DATUM) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX \#ALINK) |of| DATUM)) (|replace| (FX 
SLOWP) |of| DATUM |with| T))))) (CLINK (IDIFFERENCE (COND ((|fetch| (FX FASTP) |of| DATUM) (|fetch| (
FX \#ALINK) |of| DATUM)) (T (|fetch| (FX \#CLINK) |of| DATUM))) \\#ALINK.OFFSET) (PROGN (|replace| (FX
 \#CLINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET)) (COND ((|fetch| (FX FASTP) |of| DATUM) (
|replace| (FX \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX SLOWP) |of|
 DATUM |with| T))))) (ALINK (IDIFFERENCE (FLOOR (|fetch| (FX \#ALINK) |of| DATUM) WORDSPERCELL) 
\\#ALINK.OFFSET) (PROGN (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX \#BLINK) |of| DATUM 
|with| (|fetch| (FX DUMMYBF) |of| DATUM)) (|replace| (FX \#CLINK) |of| DATUM |with| (|fetch| (FX 
\#ALINK) |of| DATUM)))) (|replace| (FX \#ALINK) |of| DATUM |with| (IPLUS NEWVALUE \\#ALINK.OFFSET (
SUB1 WORDSPERCELL))))) (ACLINK (SHOULDNT) (PROGN (COND ((|fetch| (FX FASTP) |of| DATUM) (|replace| (FX
 \#BLINK) |of| DATUM |with| (|fetch| (FX DUMMYBF) |of| DATUM)))) (|replace| (FX \#CLINK) |of| DATUM 
|with| (IPLUS NEWVALUE \\#ALINK.OFFSET)) (|replace| (FX \#ALINK) |of| DATUM |with| (IPLUS NEWVALUE 
\\#ALINK.OFFSET (SUB1 WORDSPERCELL))))) (* \; 
"replaces A & C Links at once more efficiently than separately") (DUMMYBF (IDIFFERENCE DATUM 
WORDSPERCELL)) (* |;;| 
"This is either an actual BF or \"residual\" BF that provides enough BF to find its IVAR slot.  This means that when a FX is copied, the cell preceding the FX is copied too."
) (IVAR (|fetch| (BF IVAR) |of| (|fetch| (FX DUMMYBF) |of| DATUM))) (CHECKED (AND (|type?| FX DATUM) (
OR (IEQ (|fetch| (FX DUMMYBF) |of| DATUM) (|fetch| (FX BLINK) |of| DATUM)) (AND (|fetch| (BF RESIDUAL)
 |of| (|fetch| (FX DUMMYBF) |of| DATUM)) (IEQ (|fetch| (BF IVAR) |of| (|fetch| (FX DUMMYBF) |of| DATUM
)) (|fetch| (BF IVAR) |of| (|fetch| (FX BLINK) |of| DATUM))))))) (FIRSTPVAR (IPLUS DATUM (|fetch| (FX 
FXSIZE) |of| T))) (* \; "stack offset of PVAR0") (FXSIZE (PROGN 10)) (* \; 
"fixed overhead from flags thru clink") (PADDING (PROGN 4)) (* \; 
"doublecell of garbage for microcode use") (FIRSTTEMP (IPLUS (|fetch| (FX FIRSTPVAR) |of| DATUM) (
|fetch| (FX NPVARWORDS) |of| DATUM) (|fetch| (FX PADDING) |of| DATUM))) (* \; 
"note that NPVARWORDS is obtained from the FNHEADER") (SIZE (IDIFFERENCE (|fetch| (FX NEXTBLOCK) |of| 
DATUM) DATUM)))))
(ACCESSFNS FSB (* |;;| "FREE STACK BLOCK -- ") (* |;;| " A piece of stack space that's free.") (* |;;|
 "The first word contains 120000Q") (* |;;| "The 2nd word is the size of the block, in words.") ((
FSBBLOCK (ADDSTACKBASE DATUM)) (CHECKED (IEQ (|fetch| (FSB FLAGWORD) |of| DATUM) \\STK.FSB.WORD))) (
BLOCKRECORD FSBBLOCK ((FLAGS BITS 3) (DUMMY BITS 13) (SIZE WORD))) (BLOCKRECORD FSBBLOCK ((FLAGWORD 
WORD) (SIZE WORD))) (* \; "free stack block") (TYPE? (IEQ (|fetch| (FSB FLAGS) |of| DATUM) \\STK.FSB))
)
(ACCESSFNS STK ((STKBLOCK (ADDSTACKBASE DATUM))) (* \; "unspecified stack block") (BLOCKRECORD 
STKBLOCK ((FLAGS BITS 3))) (BLOCKRECORD STKBLOCK ((FLAGWORD WORD))))
(RPAQQ \\#ALINK.OFFSET 10)
(CONSTANTS \\#ALINK.OFFSET)
(GLOBALVARS \\PENDINGINTERRUPT \\KBDSTACKBASE \\MISCSTACKBASE \\STACKOVERFLOW)
(PUTPROPS \\MYALINK DMACRO (NIL ((OPCODES MYALINK))))
(PUTPROPS ADDSTACKBASE DMACRO (= . STACKADDBASE))
(PUTPROPS STACKADDBASE DMACRO ((N) (VAG2 \\STACKHI N)))
(PUTPROPS STACKGETBASE DMACRO ((N) (\\GETBASE (STACKADDBASE N) 0)))
(PUTPROPS STACKGETBASEPTR DMACRO ((N) (\\GETBASEPTR (STACKADDBASE N) 0)))
(PUTPROPS STACKPUTBASE DMACRO ((N V) (\\PUTBASE (STACKADDBASE N) 0 V)))
(PUTPROPS STACKPUTBASEPTR DMACRO ((N V) (\\PUTBASEPTR (STACKADDBASE N) 0 V)))
(PUTPROPS \\MISCAPPLY* MACRO ((FN ARG1 ARG2) (UNINTERRUPTABLY (|replace| (IFPAGE MISCSTACKFN) |of| 
|\\InterfacePage| |with| FN) (|replace| (IFPAGE MISCSTACKARG1) |of| |\\InterfacePage| |with| ARG1) (
|replace| (IFPAGE MISCSTACKARG2) |of| |\\InterfacePage| |with| ARG2) (\\CONTEXTSWITCH |\\MiscFXP|) (
|fetch| (IFPAGE MISCSTACKRESULT) |of| |\\InterfacePage|))))
(BLOCKRECORD STACKP ((STACKP0 WORD) (EDFXP WORD)) (BLOCKRECORD STACKP ((STACKPOINTER FULLXPOINTER))) (
TYPE? (STACKP DATUM)))
(RPAQQ STACKTYPES (\\STK.GUARD \\STK.FX \\STK.BF \\STK.NOTFLAG \\STK.FSB \\STK.FLAGS.SHIFT (
\\STK.FSB.WORD (LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (\\STK.GUARD.WORD (LLSH \\STK.GUARD 
\\STK.FLAGS.SHIFT)) (\\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT))))
(RPAQQ \\STK.GUARD 7)
(RPAQQ \\STK.FX 6)
(RPAQQ \\STK.BF 4)
(RPAQQ \\STK.NOTFLAG 0)
(RPAQQ \\STK.FSB 5)
(RPAQQ \\STK.FLAGS.SHIFT 13)
(RPAQ \\STK.FSB.WORD (LLSH \\STK.FSB \\STK.FLAGS.SHIFT))
(RPAQ \\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT))
(RPAQ \\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT))
(CONSTANTS \\STK.GUARD \\STK.FX \\STK.BF \\STK.NOTFLAG \\STK.FSB \\STK.FLAGS.SHIFT (\\STK.FSB.WORD (
LLSH \\STK.FSB \\STK.FLAGS.SHIFT)) (\\STK.GUARD.WORD (LLSH \\STK.GUARD \\STK.FLAGS.SHIFT)) (
\\STK.BF.WORD (LLSH \\STK.BF \\STK.FLAGS.SHIFT)))
(RPAQQ |\\StackAreaSize| 768)
(RPAQ |\\InitStackSize| (ITIMES |\\StackAreaSize| 12))
(CONSTANTS |\\StackAreaSize| (|\\InitStackSize| (ITIMES |\\StackAreaSize| 12)))
(RPAQQ \\MAXSAFEUSECOUNT 200)
(CONSTANTS \\MAXSAFEUSECOUNT)
(BLOCKRECORD NAMETABLESLOT ((VARTYPE BYTE) (VAROFFSET BYTE)))
(BLOCKRECORD FVARSLOT ((BINDLO WORD) (BINDHI WORD)) (ACCESSFNS FVARSLOT ((LOOKEDUP (EVENP (|fetch| 
BINDLO |of| DATUM))) (BINDINGPTR (\\VAG2 (|fetch| BINDHI |of| DATUM) (|fetch| BINDLO |of| DATUM)) (
PROGN (|replace| BINDLO |of| DATUM |with| (\\LOLOC NEWVALUE)) (|replace| BINDHI |of| DATUM |with| (
\\HILOC NEWVALUE)))))))
(BLOCKRECORD PVARSLOT ((PVHI BITS 4) (PVVALUE XPOINTER)) (ACCESSFNS PVARSLOT ((BOUND (EQ (|fetch| (
PVARSLOT PVHI) |of| DATUM) 0) (|if| (NULL NEWVALUE) |then| (|replace| (PVARSLOT PVHI) |of| DATUM 
|with| 255) |else| (ERROR "Illegal replace" NEWVALUE))))))
(BLOCKRECORD STKTEMPSLOT ((STKTMPHI BITS 4) (VALUE XPOINTER)) (ACCESSFNS STKTEMPSLOT ((BINDINGPTRP (
NEQ (|fetch| STKTMPHI |of| DATUM) 0)))))
(BLOCKRECORD BINDMARKSLOT ((BINDMARKP FLAG) (NIL BITS 15)) (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES 
WORD) (BINDLASTPVAR WORD))) (ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN (* \; 
"Value stored in high half is one's complement of number of values bound") (LOGXOR (|fetch| 
BINDNEGVALUES |of| DATUM) 65535))))))
(RPAQQ \\NT.IVAR 0)
(RPAQQ \\NT.PVAR 128)
(RPAQQ \\NT.FVAR 192)
(CONSTANTS \\NT.IVAR \\NT.PVAR \\NT.FVAR)
(PUTPROP (QUOTE LLSTK) (QUOTE IMPORTDATE) (IDATE " 6-Jan-1993 18:07:37"))

(PUTPROPS WORDCONTENTS BYTEMACRO ((PTR) (\\GETBASE PTR 0)))
(PUTPROPS SETWORDCONTENTS BYTEMACRO ((PTR N) (\\PUTBASE PTR 0 N)))
(PUTPROPS WORDOFFSET BYTEMACRO ((PTR N) (\\ADDBASE PTR N)))
(PUTPROPS \\RELEASECPAGE MACRO ((STREAM) (PROGN (* \; "Must be under an UNINTERRUPTABLY !") (COND ((
|fetch| CBUFDIRTY |of| STREAM) (\\SETIODIRTY STREAM (|fetch| CPAGE |of| STREAM)) (|replace| CBUFDIRTY 
|of| STREAM |with| NIL))) (|replace| CBUFSIZE |of| STREAM |with| 0) (|replace| CBUFPTR |of| STREAM 
|with| NIL))))
(PUTPROP (QUOTE PMAP) (QUOTE IMPORTDATE) (IDATE " 3-Feb-2002 14:11:02"))

(PUTPROPS ADDREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\\ADDREF PTR))))
(PUTPROPS \\ADDREF DMACRO ((X) ((OPCODES GCREF 0) X)))
(PUTPROPS DELETEREF MACRO (OPENLAMBDA (PTR) (PROG1 PTR (\\DELREF PTR))))
(PUTPROPS \\DELREF DMACRO ((X) ((OPCODES GCREF 1) X)))
(PUTPROPS SCANREF MACRO (= . \\STKREF))
(PUTPROPS \\STKREF DMACRO ((X) ((OPCODES GCREF 2) X)))
(PUTPROPS UNSCANREF MACRO ((PTR) (\\HTFIND PTR 3)))
(PUTPROPS CREATEREF MACRO (= . \\CREATEREF))
(PUTPROPS \\CREATEREF MACRO (OPENLAMBDA (PTR) (PROG1 (\\DELREF PTR) (.INCREMENT.ALLOCATION.COUNT. 1)))
)
(PUTPROPS .INCREMENT.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \\RECLAIM.COUNTDOWN)
) (AND \\RECLAIM.COUNTDOWN (COND ((IGREATERP \\RECLAIM.COUNTDOWN N) (SETQ \\RECLAIM.COUNTDOWN (
IDIFFERENCE \\RECLAIM.COUNTDOWN N))) (T (SETQ \\RECLAIM.COUNTDOWN) (\\DORECLAIM))))))
(PUTPROPS .CHECK.ALLOCATION.COUNT. MACRO (OPENLAMBDA (N) (DECLARE (GLOBALVARS \\RECLAIM.COUNTDOWN)) (
AND \\RECLAIM.COUNTDOWN (COND ((NOT (IGREATERP \\RECLAIM.COUNTDOWN N)) (SETQ \\RECLAIM.COUNTDOWN) (
\\DORECLAIM))))))
(PUTPROPS \\GCDISABLED MACRO (NIL (PROGN (DECLARE (GLOBALVARS \\GCDISABLED)) \\GCDISABLED)))
(BLOCKRECORD HTOVERFLOW ((CASE BITS 4) (PTR XPOINTER)) (ACCESSFNS HTOVERFLOW ((CLEAR NIL (\\PUTBASEPTR
 DATUM 0 NIL)))))
(BLOCKRECORD GC ((CNT BITS 15) (STKBIT FLAG) (HIBITS BITS 15) (LINKP FLAG) (NXTPTR FIXP)) (BLOCKRECORD
 GC ((STKCNT WORD))) (ACCESSFNS GC ((EMPTY (EQ 0 (\\GETBASEFIXP DATUM 0)) (\\PUTBASEFIXP DATUM 0 0)) (
CONTENTS (\\GETBASEFIXP DATUM 0) (\\PUTBASEFIXP DATUM 0 NEWVALUE)) (LINKPTR (LOGAND (\\GETBASEFIXP 
DATUM 0) -2) (\\PUTBASEFIXP DATUM 0 (LOGOR NEWVALUE 1))))))
(BLOCKRECORD HTCOLL ((* |;;| 
"An entry in the GC collision table.  NEXTFREE is initialized to 2 by INITGC, as part of the MAKEINIT."
) (FREEPTR FIXP) (* \; "The GC table entry") (NEXTFREE FIXP) (* \; 
"If the entry is in use, points to the next entry in this collision chain.  If not, offset (in 1/2-entries) of the next free one on the chain."
)))
(PUTPROP (QUOTE LLGC) (QUOTE IMPORTDATE) (IDATE "19-Oct-1994 12:30:11"))

(PUTPROPS \\SYNCODE DMACRO (OPENLAMBDA (TABLE CHAR) (CHECK (|type?| CHARTABLE TABLE)) (* \; 
"0 is either NONE.TC, REAL.CCE, or OTHER.RC") (COND ((IGREATERP CHAR \\MAXTHINCHAR) (OR (AND (|fetch| 
(CHARTABLE NSCHARHASH) |of| TABLE) (GETHASH CHAR (|fetch| (CHARTABLE NSCHARHASH) |of| TABLE))) 0)) (T 
(\\GETBASEBYTE TABLE CHAR)))))
(PUTPROPS \\SETSYNCODE DMACRO (LAMBDA (TABLE CHAR CODE) (CHECK (|type?| CHARTABLE TABLE)) (* \; 
"0 is REAL.CCE, NONE.TC, OTHER.RC") (COND ((ILEQ CHAR \\MAXTHINCHAR) (\\PUTBASEBYTE TABLE CHAR CODE)) 
(T (\\SETFATSYNCODE TABLE CHAR CODE)))))
(DATATYPE CHARTABLE ((CHARSET0 256 BYTE) (NSCHARHASH FULLPOINTER)))
(RPAQQ CCECHOMODES (REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE))
(RPAQQ REAL.CCE 0)
(RPAQQ IGNORE.CCE 8)
(RPAQQ SIMULATE.CCE 16)
(RPAQQ INDICATE.CCE 24)
(CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)
(RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC 
CTRLV.TC))
(RPAQQ NONE.TC 0)
(RPAQQ EOL.TC 1)
(RPAQQ CHARDELETE.TC 2)
(RPAQQ WORDDELETE.TC 6)
(RPAQQ WORDSEPR.TC 7)
(RPAQQ LINEDELETE.TC 3)
(RPAQQ RETYPE.TC 4)
(RPAQQ CTRLV.TC 5)
(CONSTANTS NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC)
(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 24)) (TERMCLASS (LOGAND DATUM 7))) (* \; 
"We assume that values are appropriately shifted") (CREATE (LOGOR CCECHO TERMCLASS)))
(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL (
CONTROLFLG FLAG) (ECHOFLG FLAG)) TERMSA _ (|create| CHARTABLE))
(PUTPROPS \\GETREADMACRODEF MACRO ((C TBL) (GETHASH C (|fetch| READMACRODEFS |of| TBL))))
(PUTPROPS \\GTREADTABLE MACRO (ARGS (COND ((LITATOM (CAR ARGS)) (SUBPAIR (QUOTE (X . FLG)) ARGS (QUOTE
 (SELECTQ X ((NIL T) (\\DTEST *READTABLE* (QUOTE READTABLEP))) (\\GTREADTABLE1 X . FLG))))) (T (QUOTE 
IGNOREMACRO)))))
(PUTPROPS \\GTREADTABLE1 DMACRO (ARGS (COND ((NULL (CDR ARGS)) (LIST (QUOTE \\DTEST) (CAR ARGS) (QUOTE
 (QUOTE READTABLEP)))) (T (QUOTE IGNOREMACRO)))))
(RPAQQ MACROBIT 8)
(RPAQQ BREAKBIT 16)
(RPAQQ STOPATOMBIT 32)
(RPAQQ ESCAPEBIT 64)
(RPAQQ INNERESCAPEBIT 4)
(CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
(RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR 
MACROBIT 2))))
(RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
(RPAQ WAKEUPMASK (LOGOR MACROBIT 2))
(CONSTANTS (CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2)))
(RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR 
MACROBIT 0)) (ALONE.RMC (LOGOR MACROBIT 1))))
(RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
(RPAQ FIRST.RMC (LOGOR MACROBIT 0))
(RPAQ ALONE.RMC (LOGOR MACROBIT 1))
(CONSTANTS (ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0)) (FIRST.RMC (LOGOR MACROBIT 0)) (
ALONE.RMC (LOGOR MACROBIT 1)))
(RPAQQ READCLASSES ((OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR 
ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (
LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT 
BREAKBIT 3)) (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR 
ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC 
(LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))
(RPAQQ OTHER.RC 0)
(RPAQ SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0))
(RPAQ BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))
(RPAQ STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))
(RPAQ LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))
(RPAQ RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))
(RPAQ LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))
(RPAQ RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))
(RPAQ ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6))
(RPAQ MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7))
(RPAQ PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))
(CONSTANTS (OTHER.RC 0) (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR.RC (LOGOR ESCAPEBIT 
STOPATOMBIT BREAKBIT 0)) (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (LEFTPAREN.RC (
LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (
LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT
 BREAKBIT 5)) (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT 
INNERESCAPEBIT 7)) (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)))
(RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0))))
(RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2))
(RPAQ NONIMMEDIATE.RMW (LOGOR MACROBIT 0))
(CONSTANTS (IMMEDIATE.RMW (LOGOR MACROBIT 2)) (NONIMMEDIATE.RMW (LOGOR MACROBIT 0)))
(RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT) (NOESC.RME 0)))
(RPAQ ESC.RME ESCAPEBIT)
(RPAQQ NOESC.RME 0)
(CONSTANTS (ESC.RME ESCAPEBIT) (NOESC.RME 0))
(ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT)) (ESCQUOTE (BITTEST DATUM ESCAPEBIT)) (STOPATOM 
(BITTEST DATUM STOPATOMBIT)) (INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT))) (
MACROCONTEXT (LOGAND DATUM CONTEXTMASK)) (MACROP (BITTEST DATUM MACROBIT)) (WAKEUP (LOGAND DATUM 
WAKEUPMASK)) (BREAK (BITTEST DATUM BREAKBIT))))
(RECORD READMACRODEF (MACROTYPE . MACROFN))
(DATATYPE READTABLEP ((READSA POINTER) (* \; "A CHARTABLE defining syntax of each char") (
READMACRODEFS POINTER) (* \; "A hash table associating macro chars with macro definitions") (
READMACROFLG FLAG) (* \; 
"True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)") (ESCAPEFLG 
FLAG) (* \; 
"True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)"
) (COMMONLISP FLAG) (* \; 
"True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules") (NUMBERBASE 
BITS 5) (* \; "Not used") (CASEINSENSITIVE FLAG) (* \; 
"If true, unescaped lowercase chars are converted to uppercase in symbols") (COMMONNUMSYNTAX FLAG) (* 
\; 
"True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers"
) (USESILPACKAGE FLAG) (* \; "If true, IL:READ ignores *PACKAGE* and reads in the IL package") (NIL 5 
FLAG) (DISPATCHMACRODEFS POINTER) (* \; 
"An a-list of dispatching macro char and its dispatch definitions") (HASHMACROCHAR BYTE) (* \; 
"The character code used in this read table for the # dispatch macro") (ESCAPECHAR BYTE) (* \; 
"The character code used in this read table for single escape") (MULTESCAPECHAR BYTE) (* \; 
"The character code used in this read table for multiple escape") (PACKAGECHAR BYTE) (* \; 
"The character code used in this read table for package delimiter") (READTBLNAME POINTER) (* \; 
"The canonical 'name' of this read table")) READSA _ (|create| CHARTABLE))
(PUTPROP (QUOTE ATBL) (QUOTE IMPORTDATE) (IDATE "12-Feb-2021 22:55:58"))

(DATATYPE STREAM ((* |;;| 
"First 8 words are fixed for BIN, BOUT opcodes.  Used to require length of whole datatype be multiple of 4, but Dolphin dead now."
) (COFFSET WORD) (* \; "Offset in CPPTR of next bin or bout") (CBUFSIZE WORD) (* \; 
"Offset past last byte in that buffer") (PEEKEDCHARP FLAG) (* \; 
"if true, PEEKEDCHAR contains value of recent call to unread-char") (ACCESSBITS BITS 3) (* \; 
"What kind of access file is open for (read, write, append)") (CBUFPTR POINTER) (* \; 
"Pointer to current buffer") (BYTESIZE BYTE) (* \; "Byte size of stream, always 8 for now") (CHARSET 
BYTE) (* \; 
"the current character set for this stream.  If 255, stream is not runcoded, so read-char consumes two bytes every time"
) (PEEKEDCHAR WORD) (* \; "value of unread-char call") (CHARPOSITION WORD) (* \; 
"Used by POSITION etc.") (CBUFMAXSIZE WORD) (* \; 
"on output, the size of the physical buffer--can't extend beyond this") (* |;;| 
"-------- Above fields (8 words) potentially known to microcode.  --------") (NONDEFAULTDATEFLG FLAG) 
(REVALIDATEFLG FLAG) (MULTIBUFFERHINT FLAG) (* \; 
"True if stream likes to read and write more than one buffer at a time") (USERCLOSEABLE FLAG) (* \; 
"Can be closed by CLOSEF;  NIL for terminal, dribble...") (FULLFILENAME POINTER) (* \; 
"Name by which file is known to user") (BINABLE FLAG) (* \; "BIN punts unless this bit on") (BOUTABLE 
FLAG) (* \; "BOUT punts unless this bit on") (EXTENDABLE FLAG) (* \; 
"BOUT punts when COFFSET ge CBUFFSIZE unless this bit set and COFFSET lt 512") (CBUFDIRTY FLAG) (* \; 
"true if BOUT has sullied the current buffer") (DEVICE POINTER) (* \; "FDEV of this guy") (USERVISIBLE
 FLAG) (* \; "Listed by OPENP;  NIL for terminal, dribble ...") (EOLCONVENTION BITS 2) (* \; 
"End-of-line convention") (NOTXCCS FLAG) (* \; "True if the character encoding format is not XCCS.") (
VALIDATION POINTER) (* \; 
"A number somehow identifying file, used to determine if file has changed in our absence") (CPAGE 
POINTER) (* \; "CPAGE,,COFFSET constitutes current file pointer for most randaccess streams") (EPAGE 
POINTER) (EOFFSET WORD) (* \; "Page, byte offset of eof") (LINELENGTH WORD) (* \; 
"LINELENGTH of stream, or -1 for no line length") (* |;;| 
"----Following are device-specific fields----") (* |;;| 
"Available for device-specific uses, NOT for application use.") (F1 POINTER) (F2 POINTER) (F3 POINTER)
 (F4 POINTER) (F5 POINTER) (FW6 WORD) (FW7 WORD) (FW8 WORD) (FW9 WORD) (F10 POINTER) (* |;;| 
"----Following only filled in for open streams----") (STRMBINFN POINTER) (* \; 
"Either the BIN fn from the FDEV, or a trap") (STRMBOUTFN POINTER) (* \; 
"Either the BIN fn from the FDEV, or a trap") (OUTCHARFN POINTER) (* \; 
"Called by \\OUTCHAR, the normal character printer.") (ENDOFSTREAMOP POINTER) (* \; 
"Called if EOF and we try to read.") (OTHERPROPS POINTER) (* \; "PROP LIST for holding other info.") (
IMAGEOPS POINTER) (* \; "Image operations vector") (IMAGEDATA POINTER) (* \; 
"Image instance variables--format depends on IMAGEOPS value") (BUFFS POINTER) (* \; 
"Buffer chain for pmapped streams") (MAXBUFFERS WORD) (* \; 
"Max # of buffers the system will allocate.") (LASTCCODE WORD) (* \; 
"After READ, RATOM, etc, the charcode that will be returned (as a character) by LASTC.  If there is none, this field is 65535."
) (EXTRASTREAMOP POINTER) (* \; "For use of applications programs, not devices")) (BLOCKRECORD STREAM 
((NIL 2 WORD) (UCODEFLAGS1 BITS 1) (* |;;| "respecification of access bits:") (RANDOMWRITEABLE FLAG) (
* \; "File open for output (access = OUTPUT or BOTH)") (APPENDABLE FLAG) (* \; 
"File open for append (OUTPUT or APPEND or BOTH)") (READABLE FLAG) (* \; 
"File open for read (READ or BOTH)") (NIL POINTER))) (BLOCKRECORD STREAM ((NIL 4 WORD) (NIL BITS 14) (
* |;;| "JIS character encoding format specific, overrides CHARSET field.") (IN.KANJIIN FLAG) (* \; 
"True if input stream is in Kanji-in mode.") (OUT.KANJIIN FLAG) (* \; 
"True if output stream is in Kanji-in mode."))) (ACCESSFNS STREAM ((ACCESS \\GETACCESS \\SETACCESS) (
FULLNAME (OR (|fetch| (STREAM FULLFILENAME) |of| DATUM) DATUM)) (NAMEDP (AND (|fetch| (STREAM 
FULLFILENAME) |of| DATUM) T)))) (ACCESSFNS STREAM (EXTERNALFORMAT (LISTGET (|ffetch| (STREAM 
OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)) (LET ((PROPS (|ffetch| (STREAM OTHERPROPS) |of| DATUM)
)) (|freplace| (STREAM NOTXCCS) |of| DATUM |with| T) (COND (PROPS (LISTPUT PROPS (QUOTE EXTERNALFORMAT
) NEWVALUE)) (T (|freplace| (STREAM OTHERPROPS) |of| DATUM |with| (LIST (QUOTE EXTERNALFORMAT) 
NEWVALUE)))) (|freplace| (STREAM OUTCHARFN) |of| DATUM |with| (|ffetch| (EXTERNALFORMAT FILEOUTCHARFN)
 |of| NEWVALUE)) (AND (|ffetch| (EXTERNALFORMAT EOLVALID) |of| NEWVALUE) (|freplace| (STREAM 
EOLCONVENTION) |of| DATUM |with| (|ffetch| (EXTERNALFORMAT EOL) |of| NEWVALUE)))))) (ACCESSFNS STREAM 
(EXTERNALFORMAT.NAME (LISTGET (|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT.NAME)) (
LET ((PROPS (|ffetch| (STREAM OTHERPROPS) |of| DATUM)) (NAME (COND ((LITATOM NEWVALUE) NEWVALUE) (T (
MKATOM NEWVALUE))))) (|freplace| (STREAM NOTXCCS) |of| DATUM |with| T) (COND (PROPS (LISTPUT PROPS (
QUOTE EXTERNALFORMAT.NAME) NAME)) (T (|freplace| (STREAM OTHERPROPS) |of| DATUM |with| (LIST (QUOTE 
EXTERNALFORMAT.NAME) NAME))))))) (ACCESSFNS STREAM (INCCODEFN (LET ((XFMT (LISTGET (|ffetch| (STREAM 
OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch| (
EXTERNALFORMAT INCCODEFN) |of| XFMT))))) (ACCESSFNS STREAM (PEEKCCODEFN (LET ((XFMT (LISTGET (|ffetch|
 (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) (|fetch|
 (EXTERNALFORMAT PEEKCCODEFN) |of| XFMT))))) (ACCESSFNS STREAM (BACKCHARFN (LET ((XFMT (LISTGET (
|ffetch| (STREAM OTHERPROPS) |of| DATUM) (QUOTE EXTERNALFORMAT)))) (AND (|type?| EXTERNALFORMAT XFMT) 
(|fetch| (EXTERNALFORMAT BACKCHARFN) |of| XFMT))))) (ACCESSFNS STREAM (FILEOUTCHARFN (|ffetch| (STREAM
 OUTCHARFN) |of| DATUM))) (SYNONYM CBUFPTR (CPPTR)) USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ 
|NoBits| CPAGE _ 0 EPAGE _ 0 BUFFS _ NIL BYTESIZE _ 8 CBUFPTR _ NIL MAXBUFFERS _ (LET NIL (DECLARE (
GLOBALVARS \\STREAM.DEFAULT.MAXBUFFERS)) \\STREAM.DEFAULT.MAXBUFFERS) CHARPOSITION _ 0 LINELENGTH _ (
LET NIL (DECLARE (GLOBALVARS FILELINELENGTH)) FILELINELENGTH) OUTCHARFN _ (FUNCTION \\FILEOUTCHARFN) 
ENDOFSTREAMOP _ (FUNCTION \\EOSERROR) IMAGEOPS _ \\NOIMAGEOPS EOLCONVENTION _ (SELECTQ (SYSTEMTYPE) (D
 CR.EOLC) (VAX LF.EOLC) (JERICHO CRLF.EOLC) CR.EOLC) STRMBINFN _ (FUNCTION \\STREAM.NOT.OPEN) 
STRMBOUTFN _ (FUNCTION \\STREAM.NOT.OPEN) LASTCCODE _ 65535 NOTXCCS _ NIL)
(PUTPROPS STREAMOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) (
QUOTE QUOTE)) (LIST (QUOTE |fetch|) (CADAR ARGS) (QUOTE |of|) (CADR ARGS))) (T (HELP 
"STREAMOP - OPNAME not quoted:" ARGS))) (CDDR ARGS)))))
(RPAQQ |AppendBit| 2)
(RPAQQ |NoBits| 0)
(RPAQQ |ReadBit| 1)
(RPAQQ |WriteBit| 4)
(RPAQ |OutputBits| (LOGOR |AppendBit| |WriteBit|))
(RPAQ |BothBits| (LOGOR |ReadBit| |OutputBits|))
(RPAQQ \\NORUNCODE 255)
(CONSTANTS |AppendBit| |NoBits| |ReadBit| |WriteBit| (|OutputBits| (LOGOR |AppendBit| |WriteBit|)) (
|BothBits| (LOGOR |ReadBit| |OutputBits|)) \\NORUNCODE)
(PUTPROPS |TestMasked| MACRO ((BITS MASK) (NEQ (LOGAND BITS MASK) 0)))
(PUTPROPS APPENDABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |AppendBit|)))
(PUTPROPS APPENDONLY MACRO ((STREAM) (EQ (|fetch| ACCESSBITS |of| STREAM) |AppendBit|)))
(PUTPROPS DIRTYABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) (CONSTANT (LOGOR 
|AppendBit| |WriteBit|)))))
(PUTPROPS OPENED MACRO ((STREAM) (NEQ (|fetch| ACCESSBITS |of| STREAM) |NoBits|)))
(PUTPROPS OVERWRITEABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |WriteBit|)))
(PUTPROPS READABLE MACRO ((STREAM) (|TestMasked| (|fetch| ACCESSBITS |of| STREAM) |ReadBit|)))
(PUTPROPS READONLY MACRO ((STREAM) (EQ (|fetch| ACCESSBITS |of| STREAM) |ReadBit|)))
(PUTPROPS WRITEABLE MACRO ((STREAM) (OR (OVERWRITEABLE STREAM) (AND (APPENDABLE STREAM) (\\EOFP STREAM
)))))
(PUTPROPS \\RUNCODED MACRO (OPENLAMBDA (STREAM) (* |;;| 
"returns NIL is the stream is not runcoded, that is, if the stream has 16 bit bytes explicitly represented"
) (* \; "note that neq is ok since charsets are known to be SMALLP's") (NEQ (|fetch| CHARSET |of| 
STREAM) \\NORUNCODE)))
(RPAQQ EOLCONVENTIONS ((CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2)))
(RPAQQ CR.EOLC 0)
(RPAQQ LF.EOLC 1)
(RPAQQ CRLF.EOLC 2)
(CONSTANTS (CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2))
(PUTPROPS FDEVOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS))
) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (|fetch| (FDEV (
\\\, (CADR OPNAME))) |of| (\\\, METHOD-DEVICE)) (\\\,@ TAIL)))) (T (ERROR "OPNAME not quoted: " OPNAME
))))))
(PUTPROPS \\RECOGNIZE-HACK DMACRO (ARGS (LET ((NAME (CAR ARGS)) (RECOG (CADR ARGS)) (DEVICE (CADDR 
ARGS))) (BQUOTE (|if| (|type?| STREAM (\\\, NAME)) |then| (\\\, NAME) |else| (FDEVOP (QUOTE 
GETFILENAME) (\\\, DEVICE) (\\\, NAME) (\\\, RECOG) (\\\, DEVICE)))))))
(DATATYPE FDEV ((RESETABLE FLAG) (* \; "Obsolete") (RANDOMACCESSP FLAG) (NODIRECTORIES FLAG) (
PAGEMAPPED FLAG) (* \; "True if i/o handled by pmap routines") (FDBINABLE FLAG) (* \; 
"Copied as a microcode flag for INPUT streams formed on this device") (FDBOUTABLE FLAG) (FDEXTENDABLE 
FLAG) (BUFFERED FLAG) (* \; 
"True implies that the device supports the BIN & BOUT uCode conventions, and implements the GETNEXTBUFFER method"
) (DEVICENAME POINTER) (* \; "Identifying name somehow") (REMOTEP FLAG) (* \; 
"true if device not local to machine") (SUBDIRECTORIES FLAG) (* \; 
"true if device has real subdirectories") (INPUT-INDIRECTED FLAG) (* \; 
"True for devices that indirect their input stream.  Method INPUTSTREAM fetches it") (
OUTPUT-INDIRECTED FLAG) (* \; 
"True for devices that indirect their output stream.  Method OUTPUTSTREAM fetches it") (DEVICEINFO 
POINTER) (* \; "arbitrary device-specific info stored here") (OPENFILELST POINTER) (* \; 
"Default place to keep list of streams open on this device") (* |;;| 
"-----Rest of record consists of device \"methods\"-----") (* |;;| 
"-----Following fields required of all devices-----") (HOSTNAMEP POINTER) (* \; 
"(hostname {device}) => T if hostname is valid.  If device is given, return a FDEV for this {new} host, or T to use existing device"
) (EVENTFN POINTER) (* \; "(device event), called before/after logout, sysout, makesys") (* |;;| 
"-----Following fields required of all named devices, e.g., ones that open files-----") (
DIRECTORYNAMEP POINTER) (* \; "(host/dir) => true if directory exists on host") (OPENFILE POINTER) (* 
\; "(name access recog otherinfo device) => new stream open on this device, or NIL if name not found")
 (CLOSEFILE POINTER) (* \; "(stream) => closes stream, returns it") (REOPENFILE POINTER) (* \; 
"(name access recog otherinfo device stream) like openfile, but called after logout to revalidate file, so optionally uses info in old stream to keep this opening like the previous"
) (GETFILENAME POINTER) (* \; "(name recog device) => full file name") (DELETEFILE POINTER) (* \; 
"(name) => deletes file so named, returning name, or NIL on failure.  RECOG=OLDEST") (GENERATEFILES 
POINTER) (* \; 
"(device pattern) => generator object for files matching pattern.  Car of object is generator function, cdr is arbitrary state.  Generator fn returns next file, or NIL when finished"
) (RENAMEFILE POINTER) (* \; 
"(olddevice oldfile newdevice newfile) to rename file on this (olddevice) to a potentially different device."
) (OPENP POINTER) (* \; 
"(name access dev) => stream if name is open for access, or all open streams if name = NIL") (
REGISTERFILE POINTER) (* \; "(stream dev) => registers stream on its device") (UNREGISTERFILE POINTER)
 (* \; "(stream dev) => unregisters a stream from its device") (FREEPAGECOUNT POINTER) (* \; 
"(host/dir dev) => # of free pages on host/dir") (MAKEDIRECTORY POINTER) (* \; "(host/dir dev)") (
CHECKFILENAME POINTER) (* \; "(name dev) => name if it is well-formed file name for dev") (HOSTALIVEP 
POINTER) (* \; 
"(host dev) => true if host is alive, i.e., responsive;  only defined if REMOTEP is true") (
BREAKCONNECTION POINTER) (* \; "(host fastp dev) => closes connections to host") (* |;;| 
"-----The following are required methods for operating on open streams-----") (BIN POINTER) (* \; 
"(stream) => next byte of input") (BOUT POINTER) (* \; "(stream byte) output byte to stream") (PEEKBIN
 POINTER) (* \; "(stream) => next byte without advancing position in stream") (READCHAR POINTER) (* \;
 "(stream) => next input char") (WRITECHAR POINTER) (* \; "(stream char) => writes char to stream") (
PEEKCHAR POINTER) (UNREADCHAR POINTER) (READP POINTER) (* \; 
"(stream flag) => T if there is input available from stream right now") (EOFP POINTER) (* \; 
"(stream) => T if BIN would signal eof.") (BLOCKIN POINTER) (* \; "(stream buffer byteoffset nbytes)")
 (BLOCKOUT POINTER) (* \; "(stream buffer byteoffset nbytes)") (FORCEOUTPUT POINTER) (* \; 
"(stream waitForFinish) flushes out to device anything that is buffered awaiting transmission") (
GETFILEINFO POINTER) (* \; 
"(stream/name attribute device) => value of attribute for open stream or name of closed file") (
SETFILEINFO POINTER) (* \; 
"(stream/name attribute newvalue device) sets attribute of open stream or closed file of given name") 
(CHARSETFN POINTER) (* \; 
"(stream charset) => access function for the charset slot, for benefit of indirect streams.  See IMCHARSET for changing it on a file."
) (INPUTSTREAM POINTER) (* \; "(stream) => indirected input stream") (OUTPUTSTREAM POINTER) (* \; 
"(stream) => indirected output stream") (* |;;| 
"-----Following are required of random-access streams-----") (GETFILEPTR POINTER) (GETEOFPTR POINTER) 
(SETFILEPTR POINTER) (BACKFILEPTR POINTER) (* \; 
"(stream) backs up `fileptr' by one.  Stream is only required to be able to do this once, i.e.  one-character buffer suffices"
) (SETEOFPTR POINTER) (* \; "(stream length) => truncates or lengthens stream to indicated length") (
LASTC POINTER) (* \; "Should be possible only if RANDOMACCESSP") (* |;;| 
"-----Following used for buffered streams-----") (GETNEXTBUFFER POINTER) (* \; 
"(stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next.  whatfor is READ or WRITE.  Can cause EOF error unless noerrorflg"
) (RELEASEBUFFER POINTER) (* \; "(stream) => Does whatever appropriate when CBUFPTR is released") (* 
|;;| "-----Following used for pagemapped streams-----") (READPAGES POINTER) (* \; 
"(stream firstpage# buflist) => # of bytes read, starting at firstpage#, reading into buflist, a list of buffers or a single buffer (the usual case)"
) (WRITEPAGES POINTER) (* \; 
"(stream firstpage# buflist) writes from buflist to stream starting at firstpage# of stream") (
TRUNCATEFILE POINTER) (* \; 
"(stream page offset) make stream's eof be at page,offset, discarding anything after it") (* |;;| 
"-----For window system, argh-----") (WINDOWOPS POINTER) (* \; "window system operations") (WINDOWDATA
 POINTER) (* \; "data for window systems") (* |;;| 
"-----For any stream (here to not recompile everything)-----") (READCHARCODE POINTER) (* \; 
"Read a character code from the stream (cf BIN for bytes).")) DIRECTORYNAMEP _ (FUNCTION NILL) 
HOSTNAMEP _ (FUNCTION NILL) READP _ (FUNCTION \\GENERIC.READP) SETFILEPTR _ (FUNCTION 
\\IS.NOT.RANDACCESSP) GETFILEPTR _ (FUNCTION \\ILLEGAL.DEVICEOP) GETEOFPTR _ (FUNCTION 
\\IS.NOT.RANDACCESSP) EOFP _ (FUNCTION \\ILLEGAL.DEVICEOP) BLOCKIN _ (FUNCTION \\GENERIC.BINS) 
BLOCKOUT _ (FUNCTION \\GENERIC.BOUTS) RENAMEFILE _ (FUNCTION \\GENERIC.RENAMEFILE) FORCEOUTPUT _ (
FUNCTION NILL) REGISTERFILE _ (FUNCTION NILL) OPENP _ (FUNCTION NILL) UNREGISTERFILE _ (FUNCTION NILL)
 READCHAR _ (FUNCTION \\GENERIC.READCHAR) WRITECHAR _ (FUNCTION \\GENERIC.WRITECHAR) PEEKCHAR _ (
FUNCTION \\GENERIC.PEEKCHAR) UNREADCHAR _ (FUNCTION \\GENERIC.UNREADCHAR) CHARSETFN _ (FUNCTION 
\\GENERIC.CHARSET) BREAKCONNECTION _ (FUNCTION NILL) READCHARCODE _ (FUNCTION \\GENERIC.READCCODE))
(RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE))
(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (* \; 
"If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream.") (EOL 
BITS 2) (NIL BITS 1) (INCCODEFN POINTER) (* \; "Called with two arguments -- STREAM and COUNTP") (
PEEKCCODEFN POINTER) (* \; "Called with three arguments -- STREAM, NOERROR and COUNTP") (BACKCHARFN 
POINTER) (* \; "Called with two arguments -- STREAM and COUNTP") (FILEOUTCHARFN POINTER) (* \; 
"Called with two arguments -- STREAM and CHARCODE")) EOLVALID _ NIL)
(PUTPROPS \\OUTCHAR DMACRO (OPENLAMBDA (STREAM CHARCODE) (STREAMOP (QUOTE OUTCHARFN) STREAM STREAM 
CHARCODE)))
(PUTPROPS \\DEVICE-OPEN-STREAMS MACRO (ARGS (LET ((DEVICE (CAR ARGS))) (BQUOTE (FDEVOP (QUOTE OPENP) (
\\\, DEVICE) NIL NIL (\\\, DEVICE))))))
(PUTPROPS \\CONVERT-PATHNAME DMACRO (OPENLAMBDA (PATHNAME?) (* |;;| 
"Coerce pathnames to Interlisp strings, for the benefit of antediluvian Interlisp-D file fns") (
CL:TYPECASE PATHNAME? (PATHNAME (INTERLISP-NAMESTRING PATHNAME?)) (T PATHNAME?))))
(DEFOPTIMIZER ACCESS-CHARSET (STREAM &OPTIONAL NEWVALUE) (BQUOTE ((OPENLAMBDA (STRM) (FDEVOP (QUOTE 
CHARSETFN) (|fetch| (STREAM DEVICE) |of| STRM) STRM (\\\, NEWVALUE))) (\\\, STREAM))))
(PUTPROPS \\DECFILEPTR MACRO ((STREAM X) (\\INCFILEPTR STREAM (IMINUS X))))
(PUTPROPS \\GETFILEPTR MACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE GETFILEPTR) (|fetch| DEVICE |of| STRM) 
STRM)))
(PUTPROPS \\SIGNEDWIN MACRO ((STREAM) (SIGNED (\\WIN STREAM) BITSPERWORD)))
(PUTPROPS \\SIGNEDWOUT MACRO ((STREAM N) (\\WOUT STREAM (UNSIGNED N BITSPERWORD))))
(PUTPROPS \\WIN MACRO (OPENLAMBDA (STREAM) (|create| WORD HIBYTE _ (\\BIN STREAM) LOBYTE _ (\\BIN 
STREAM))))
(PUTPROPS \\WOUT MACRO (OPENLAMBDA (STREAM W) (\\BOUT STREAM (|fetch| HIBYTE |of| W)) (\\BOUT STREAM (
|fetch| LOBYTE |of| W))))
(PUTPROPS \\BINS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKIN) (|fetch| (STREAM
 DEVICE) |of| STRM) STRM BASE OFF NBYTES)))
(PUTPROPS \\BOUTS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP (QUOTE BLOCKOUT) (|fetch| (
STREAM DEVICE) |of| STRM) STRM BASE OFF NBYTES)))
(PUTPROPS \\EOFP BYTEMACRO (OPENLAMBDA (STRM) (FDEVOP (QUOTE EOFP) (|fetch| (STREAM DEVICE) |of| STRM)
 STRM)))
(PUTPROPS SIZE.FROM.LENGTH MACRO (LAMBDA (LEN) (DECLARE (LOCALVARS LEN)) (AND LEN (FOLDHI LEN 
BYTESPERPAGE))))
(RPAQQ |BitsPerByte| 8)
(RPAQ |ByteOffsetSize| (SELECTQ (SYSTEMTYPE) (VAX 10) 9))
(RPAQQ |WordsPerPage| 256)
(CONSTANTS |BitsPerByte| (|ByteOffsetSize| (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) |WordsPerPage|)
(RPAQ \\MAXFILEPTR (SUB1 (LLSH 1 30)))
(CONSTANTS (\\MAXFILEPTR (SUB1 (LLSH 1 30))))
(ACCESSFNS BYTEPTR ((PAGE (FOLDLO DATUM BYTESPERPAGE)) (OFFSET (MOD DATUM BYTESPERPAGE))) (TYPE? (AND 
(FIXP DATUM) (IGEQ DATUM 0) (ILEQ DATUM \\MAXFILEPTR))) (CREATE (IPLUS (UNFOLD PAGE BYTESPERPAGE) 
OFFSET)))
(PUTPROP (QUOTE FILEIO) (QUOTE IMPORTDATE) (IDATE "13-Aug-2020 11:43:08"))

(BLOCKRECORD FIXP ((HINUM WORD) (LONUM WORD)) (CREATE (CREATECELL \\FIXP)) (TYPE? (EQ (NTYPX DATUM) 
\\FIXP)))
(RPAQQ MAX.SMALL.INTEGER 65535)
(RPAQQ MAX.POS.HINUM 32767)
(CONSTANTS (MAX.SMALL.INTEGER 65535) (MAX.POS.HINUM 32767))
(PUTPROPS .UNBOX. MACRO (ARGS (LET ((ARG-FORM (CAR ARGS)) (HIGH-VAR (CADR ARGS)) (LOW-VAR (CADDR ARGS)
) (BIGNUM-FORM (CADDDR ARGS))) (BQUOTE (PROG NIL UBLP (SELECTC (NTYPX (\\\, ARG-FORM)) (\\FIXP (SETQ (
\\\, HIGH-VAR) (|ffetch| (FIXP HINUM) |of| (\\\, ARG-FORM))) (SETQ (\\\, LOW-VAR) (|ffetch| (FIXP 
LONUM) |of| (\\\, ARG-FORM)))) (\\SMALLP (COND ((ILEQ 0 (\\\, ARG-FORM)) (SETQ (\\\, HIGH-VAR) 0) (
SETQ (\\\, LOW-VAR) (\\\, ARG-FORM))) (T (SETQ (\\\, HIGH-VAR) 65535) (SETQ (\\\, LOW-VAR) (\\LOLOC (
\\\, ARG-FORM)))))) (\\FLOATP (SETQ (\\\, ARG-FORM) (\\FIXP.FROM.FLOATP (\\\, ARG-FORM))) (GO UBLP)) (
COND ((TYPENAMEP (\\\, ARG-FORM) (QUOTE RATIO)) (SETQ (\\\, ARG-FORM) (IQUOTIENT (CL::RATIO-NUMERATOR 
(\\\, ARG-FORM)) (CL::RATIO-DENOMINATOR (\\\, ARG-FORM)))) (GO UBLP)) (\\\,@ (COND (BIGNUM-FORM (
BQUOTE (((CL:INTEGERP (\\\, ARG-FORM)) (\\\, BIGNUM-FORM))))) (T (BQUOTE (((CL:INTEGERP (\\\, ARG-FORM
)) (\\ILLEGAL.ARG (\\\, ARG-FORM)))))))) (T (CL::%NOT-NONCOMPLEX-NUMBER-ERROR (\\\, ARG-FORM))))))))))
(PUTPROPS .NEGATE. MACRO ((HY LY) (COND ((EQ 0 LY) (AND (NEQ HY 0) (SETQ HY (ADD1 (IDIFFERENCE 
MAX.SMALL.INTEGER HY))))) (T (SETQ HY (IDIFFERENCE MAX.SMALL.INTEGER HY)) (SETQ LY (ADD1 (IDIFFERENCE 
MAX.SMALL.INTEGER LY)))))))
(PUTPROPS .LLSH1. MACRO ((HI LO) (* \; "shift the pair left one, assuming no overflow") (SETQ HI (LLSH
 HI 1)) (SETQ LO (LLSH (COND ((IGREATERP LO MAX.POS.HINUM) (|add| HI 1) (LOGAND LO MAX.POS.HINUM)) (T 
LO)) 1))))
(PUTPROPS .LRSH1. MACRO ((HI LO) (SETQ LO (LRSH LO 1)) (COND ((NEQ (LOGAND HI 1) 0) (SETQ LO (IPLUS LO
 \\SIGNBIT)))) (SETQ HI (LRSH HI 1))))
(PUTPROPS .BOXIPLUS. MACRO (OPENLAMBDA (X Y) (PROG ((HX (\\GETBASE X 0)) (LX (\\GETBASE X 1)) HY LY) (
.UNBOX. Y HY LY) (SETQ HX (COND ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY)) (IDIFFERENCE HX (
ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY)))) (T (IPLUS HX HY)))) (* |Add| |high| |parts|) (\\PUTBASE X 1
 (COND ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY)) (* |Carry| |into| |high| |part.|) (SETQ HX (
COND ((EQ HX MAX.SMALL.INTEGER) 0) (T (ADD1 HX)))) (IDIFFERENCE LX (ADD1 (IDIFFERENCE 
MAX.SMALL.INTEGER LY)))) (T (IPLUS LX LY)))) (\\PUTBASE X 0 HX) (RETURN X))))
(PUTPROPS |PutUnboxed| DMACRO (= . \\PUTFIXP))
(PUTPROP (QUOTE LLARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 18:47:56"))

(PUTPROPS POLYEVAL DMACRO ((X COEFFS DEGREE) (* \; 
"execute the POLYEVAL opcode on the value X, the array COEFFS with degree DEGREE") (\\FLOATBOX ((
OPCODES UBFLOAT3 0) (\\FLOATUNBOX X) (|fetch| (ARRAYP BASE) |of| COEFFS) DEGREE))))
(BLOCKRECORD FLOATP ((SIGNBIT BITS 1) (EXPONENT BITS 8) (HIFRACTION BITS 7) (LOFRACTION BITS 16)) (
BLOCKRECORD FLOATP ((HIWORD WORD) (LOWORD WORD))) (BLOCKRECORD FLOATP ((NIL BITS 9) (LONGFRACTION BITS
 23))) (BLOCKRECORD FLOATP ((FLOATCONTENTS BITS 32))) (BLOCKRECORD FLOATP ((NIL BITS 1) (
HIWORDNOSIGNBIT BITS 15))) (CREATE (\\FLOATBOX (\\VAG2 (LOGOR (LLSH SIGNBIT (PLUS 7 8)) (LLSH EXPONENT
 7) HIFRACTION) LOFRACTION))) LOFRACTION _ 0 HIFRACTION _ 0 EXPONENT _ 0 SIGNBIT _ 0 (ACCESSFNS FLOATP
 ((EXP (LOGAND (LRSH (\\HILOC (\\FLOATUNBOX DATUM)) 7) 255)) (HIFRAC (LOGAND (\\HILOC (\\FLOATUNBOX 
DATUM)) 127)))))
(RPAQQ MAX.DIGITS.ACCURACY 9)
(CONSTANTS (MAX.DIGITS.ACCURACY 9))
(PUTPROPS \\CALLER.ARGS MACRO (X (LET ((ARGS (CAR X)) (FORMS (CDR X))) (BQUOTE (PROGN (\\SLOWRETURN) (
LET ((AL (\\MYALINK)) NEXT (\\\,@ (|for| VAR |in| ARGS |collect| (COND ((LISTP VAR) (LIST (CAR VAR) 0)
) (T VAR))))) (DECLARE (\\\,@ (|for| VAR |in| ARGS |when| (LISTP VAR) |collect| (BQUOTE (TYPE (\\\, (
SELECTQ (CADR VAR) ((FLOATING FLOATP) (CADR VAR)) (HELP))) (\\\, (CAR VAR))))))) (SETQ NEXT (|fetch| (
FX NEXTBLOCK) |of| AL)) (\\\,@ (|for| X |in| (REVERSE ARGS) |collect| (LET ((FORMS (BQUOTE (
\\.GETBASE32 \\STACKSPACE (SETQ NEXT (IDIFFERENCE NEXT WORDSPERCELL)))))) (COND ((LISTP X) (BQUOTE (
SETQ (\\\, (CAR X)) (\\FLOATBOX (\\\, FORMS))))) (T (BQUOTE (SETQ (\\\, X) (\\\, FORMS)))))))) (
\\MAKEFREEBLOCK NEXT (TIMES (\\\, (LENGTH ARGS)) WORDSPERCELL)) (|replace| (FX NEXTBLOCK) |of| AL 
|with| NEXT) (PROGN (\\\,@ FORMS))))))))
(PUTPROP (QUOTE LLFLOAT) (QUOTE IMPORTDATE) (IDATE "16-May-1990 19:26:51"))

(DEFOPTIMIZER FONTPROP (&REST ARGS) (SELECTQ (AND (EQ (CAADR ARGS) (QUOTE QUOTE)) (CADADR ARGS)) (
ASCENT (LIST (QUOTE FONTASCENT) (CAR ARGS))) (DESCENT (LIST (QUOTE FONTDESCENT) (CAR ARGS))) (HEIGHT (
LIST (QUOTE FONTHEIGHT) (CAR ARGS))) (QUOTE IGNOREMACRO)))
(DATATYPE FONTCLASS ((PRETTYFONT# BYTE) DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))
(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) (FONTFAMILY POINTER) (FONTSIZE POINTER) (FONTFACE 
POINTER) (|\\SFAscent| WORD) (|\\SFDescent| WORD) (|\\SFHeight| WORD) (ROTATION WORD) (FBBOX 
SIGNEDWORD) (FBBOY SIGNEDWORD) (FBBDX SIGNEDWORD) (FBBDY SIGNEDWORD) (|\\SFLKerns| POINTER) (
|\\SFRWidths| POINTER) (FONTDEVICESPEC POINTER) (* \; 
"Holds the spec by which the font is known to the printing device, if coercion has been done") (
OTHERDEVICEFONTPROPS POINTER) (* \; "For individual devices to hang special information") (FONTSCALE 
POINTER) (\\SFFACECODE BITS 8) (FONTAVGCHARWIDTH WORD) (* \; 
"Set in FONTCREATE, used to fix up the linelength when DSPFONT is called") (FONTIMAGEWIDTHS POINTER) (
* \; 
"This is the image width, as opposed to the advanced width;  initial hack for accents, kerning.  Fields is referenced by FONTCREATE."
) (FONTCHARSETVECTOR POINTER) (* \; 
"A 256-pointer block, with one pointer per 'character set' --each group of 256 character codes.  Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset."
) (FONTEXTRAFIELD2 POINTER)) FONTCHARSETVECTOR _ (\\CREATEFONTCHARSETVECTOR))
(RECORD FONTFACE (WEIGHT SLOPE EXPANSION) (ACCESSFNS ((COLOR (CDDDR DATUM) (RPLACD (CDDR DATUM) 
NEWVALUE)) (BACKCOLOR (COND ((CDDDR DATUM) (CAR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) (
RPLACD (CDDR DATUM) (LIST NIL NIL)))) (RPLACA (CDDDR DATUM) NEWVALUE))) (FORECOLOR (COND ((CDDDR DATUM
) (CADR (CDDDR DATUM)))) (PROGN (COND ((NULL (CDDDR DATUM)) (RPLACD (CDDR DATUM) (LIST NIL NIL)))) (
RPLACA (CDR (CDDDR DATUM)) NEWVALUE))))) WEIGHT _ (QUOTE MEDIUM) SLOPE _ (QUOTE REGULAR) EXPANSION _ (
QUOTE REGULAR) (TYPE? LISTP))
(DATATYPE CHARSETINFO (WIDTHS (* \; 
"The advance-width of each character, an array indexed by charcode.  Usually the same as the imagewidth, but can differ for accents, kerns kerns.  This is what should be used for stringwidth calculations."
) OFFSETS (* \; "Offset of each character into the image bitmap;  X value of left edge") IMAGEWIDTHS (
* \; "imagewidths is not automagically allocated since it is not always needed") CHARSETBITMAP (* \; 
"Bitmap containing the character images, indexed by OFFSETS") YWIDTHS (CHARSETASCENT WORD) (* \; 
"Max ascent for all characters in this CHARSET") (CHARSETDESCENT WORD) (* \; 
"Max descent for all characters in this CHARSET") LEFTKERN) WIDTHS _ (\\CREATECSINFOELEMENT) OFFSETS _
 (\\CREATECSINFOELEMENT))
(PUTPROPS FONTASCENT MACRO ((FONTSPEC) (|ffetch| |\\SFAscent| |of| (\\GETFONTDESC FONTSPEC))))
(PUTPROPS FONTDESCENT MACRO ((FONTSPEC) (|ffetch| |\\SFDescent| |of| (\\GETFONTDESC FONTSPEC))))
(PUTPROPS FONTHEIGHT MACRO ((FONTSPEC) (|ffetch| |\\SFHeight| |of| (\\GETFONTDESC FONTSPEC))))
(PUTPROPS \\FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) (\\GETBASE OFFSETSBLOCK CHAR8CODE)))
(PUTPROPS \\FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET) (\\PUTBASE OFFSETSBLOCK CHAR8CODE 
OFFSET)))
(PUTPROPS \\FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) (\\GETBASE WIDTHSBLOCK CHAR8CODE)))
(PUTPROPS \\FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
(PUTPROPS \\FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE) (\\FGETWIDTH (|ffetch| (CHARSETINFO 
WIDTHS) |of| (\\GETCHARSETINFO (\\CHARSET CHARCODE) FONTDESC)) (\\CHAR8CODE CHARCODE))))
(PUTPROPS \\FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) (\\FSETWIDTH (|ffetch| (
CHARSETINFO WIDTHS) |of| (\\GETCHARSETINFO (\\CHARSET CHARCODE) FONTDESC)) (\\CHAR8CODE CHARCODE) 
WIDTH)))
(PUTPROPS \\FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE) (\\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE))
)
(PUTPROPS \\FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
(PUTPROPS \\GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?) (* |;;| 
"fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC.  If NIL, then creates the required charset."
) (* |;;| 
"NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL") (OR
 (\\GETBASEPTR (|ffetch| FONTCHARSETVECTOR |of| FONTDESC) (UNFOLD CHARSET 2)) (\\CREATECHARSET CHARSET
 FONTDESC NOSLUG?))))
(PUTPROPS \\CREATECSINFOELEMENT MACRO (NIL (\\ALLOCBLOCK (FOLDHI (IPLUS \\MAXTHINCHAR 3) WORDSPERCELL)
)))
(PUTPROPS \\CREATEFONTCHARSETVECTOR MACRO (NIL (* \; "Allocates a block for the character set records"
) (\\ALLOCBLOCK (ADD1 \\MAXCHARSET) T)))
(DEFMACRO \\CREATEKERNELEMENT NIL (BQUOTE (CL:MAKE-ARRAY (IPLUS \\MAXTHINCHAR 3) :ELEMENT-TYPE (QUOTE 
(SIGNED-BYTE 16)) :INITIAL-ELEMENT 0)))
(DEFMACRO \\FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE) (BQUOTE (CL:SETF (CL:AREF (\\\, LEFTKERNBLOCK
) (\\\, INDEX)) (\\\, KERNVALUE))))
(DEFMACRO \\FGETLEFTKERN (LEFTKERNBLOCK CHAR8CODE) (BQUOTE (CL:AREF (\\\, LEFTKERNBLOCK) (\\\, 
CHAR8CODE))))
(RPAQQ \\MAXNSCHAR 65535)
(CONSTANTS (\\MAXNSCHAR 65535))
(PUTPROP (QUOTE FONT) (QUOTE IMPORTDATE) (IDATE " 9-Feb-2021 11:39:44"))

(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)))))
(RPAQQ \\NKEYS 112)
(CONSTANTS \\NKEYS)
(DEFOPTIMIZER KEYDOWNP (KEYNAME) (BQUOTE (\\NEWKEYDOWNP (\\KEYNAMETONUMBER (\\\, KEYNAME)))))
(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))))
(GLOBALVARS \\KEYBOARD.DEVICE \\KEYBOARD.STREAM)
(RPAQQ HARDCURSORHEIGHT 16)
(RPAQQ HARDCURSORWIDTH 16)
(CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16))
(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD)
(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)))))
(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)
(PUTPROP (QUOTE LLKEY) (QUOTE IMPORTDATE) (IDATE "13-Feb-2021 23:24:49"))

(DATATYPE PILOTBBT ((PBTDESTLO WORD) (PBTDESTHI WORD) (PBTDESTBIT WORD) (PBTDESTBPL SIGNEDWORD) (
PBTSOURCELO WORD) (PBTSOURCEHI WORD) (PBTSOURCEBIT WORD) (PBTSOURCEBPL SIGNEDWORD) (PBTWIDTH WORD) (
PBTHEIGHT WORD) (PBTFLAGS WORD) (NIL 5 WORD)) (BLOCKRECORD PILOTBBT ((NIL 7 WORD) (NIL BITS 4) (
PBTGRAYOFFSET BITS 4) (PBTGRAYWIDTHLESSONE BITS 4) (PBTGRAYHEIGHTLESSONE BITS 4) (NIL 2 WORD) (
PBTBACKWARD FLAG) (PBTDISJOINT FLAG) (PBTDISJOINTITEMS FLAG) (PBTUSEGRAY FLAG) (PBTSOURCETYPE BITS 1) 
(PBTOPERATION BITS 2) (NIL BITS 9))) (ACCESSFNS PILOTBBT ((PBTSOURCE (\\VAG2 (|fetch| PBTSOURCEHI |of|
 DATUM) (|fetch| PBTSOURCELO |of| DATUM)) (PROGN (|replace| PBTSOURCEHI |of| DATUM |with| (\\HILOC 
NEWVALUE)) (|replace| PBTSOURCELO |of| DATUM |with| (\\LOLOC NEWVALUE)))) (PBTDEST (\\VAG2 (|fetch| 
PBTDESTHI |of| DATUM) (|fetch| PBTDESTLO |of| DATUM)) (PROGN (|replace| PBTDESTHI |of| DATUM |with| (
\\HILOC NEWVALUE)) (|replace| PBTDESTLO |of| DATUM |with| (\\LOLOC NEWVALUE)))))) (SYSTEM))
(DATATYPE \\DISPLAYDATA (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET |DDDestination| 
|DDClippingRegion| DDFONT |DDSlowPrintingCase| DDWIDTHSCACHE DDOFFSETSCACHE DDCOLOR DDLINEFEED 
|DDRightMargin| |DDLeftMargin| |DDScroll| DDOPERATION DDSOURCETYPE (|DDClippingLeft| WORD) (
|DDClippingRight| WORD) (|DDClippingBottom| WORD) (|DDClippingTop| WORD) (NIL WORD) (DDHELDFLG FLAG) (
XWINDOWHINT XPOINTER) (DDPILOTBBT POINTER) DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS DDEOLFN DDPAGEFULLFN 
|DDTexture| DDMICAXPOS DDMICAYPOS DDMICARIGHTMARGIN DDCHARSET (DDCHARSETASCENT WORD) (DDCHARSETDESCENT
 WORD) DDCHARHEIGHTDELTA (DDSPACEWIDTH WORD)) DDPILOTBBT _ (|create| PILOTBBT PBTDISJOINT _ T) 
|DDLeftMargin| _ 0 |DDRightMargin| _ SCREENWIDTH DDXPOSITION _ 0 DDYPOSITION _ 0 DDXOFFSET _ 0 
DDYOFFSET _ 0 |DDClippingRegion| _ (|create| REGION) |DDDestination| _ |ScreenBitMap| DDXSCALE _ 1 
DDYSCALE _ 1 |DDTexture| _ 0 (ACCESSFNS ((DDFOREGROUNDCOLOR (PROG ((VAL (|fetch| (\\DISPLAYDATA 
DDCOLOR) |of| DATUM))) (OR (FIXP VAL) (BITMAPP VAL) (AND (NULL VAL) 1) (CAR VAL) (MAXIMUMCOLOR (
BITSPERPIXEL (|fetch| (\\DISPLAYDATA |DDDestination|) |of| DATUM)))))) (DDBACKGROUNDCOLOR (OR (|fetch|
 (\\DISPLAYDATA |DDTexture|) |of| DATUM) 0)))) (SYSTEM))
(RECORD DISPLAYSTATE (ONOFF))
(RECORD DISPLAYINFO (DITYPE DIWIDTH DIHEIGHT DIBITSPERPIXEL DIWSOPS))
(PUTPROPS \\GETDISPLAYDATA MACRO (ARGS (COND ((CADR ARGS) (SUBPAIR (QUOTE (STRM STRMVAR)) ARGS (QUOTE 
(\\DTEST (|fetch| (STREAM IMAGEDATA) |of| (SETQ STRMVAR (\\OUTSTREAMARG STRM))) (QUOTE \\DISPLAYDATA))
))) (T (SUBST (CAR ARGS) (QUOTE STRM) (QUOTE (\\DTEST (|fetch| (STREAM IMAGEDATA) |of| (\\OUTSTREAMARG
 STRM)) (QUOTE \\DISPLAYDATA))))))))
(PUTPROPS \\BITMASK MACRO ((N) (\\WORDELT BITMASKARRAY (LOGAND N 15))))
(PUTPROPS \\4BITMASK MACRO ((N) (\\WORDELT 4BITMASKARRAY (LOGAND N 3))))
(PUTPROPS \\NOTBITMASK MACRO ((N) (DECLARE (GLOBALVARS NOTBITMASKARRAY)) (\\WORDELT NOTBITMASKARRAY (
LOGAND N 15))))
(PUTPROPS \\NOT4BITMASK MACRO ((N) (\\WORDELT NOT4BITMASKARRAY (LOGAND N 3))))
(GLOBALVARS BITMASKARRAY NOTBITMASKARRAY 4BITMASKARRAY NOT4BITMASKARRAY)
(RPAQQ WORDMASK 65535)
(CONSTANTS (WORDMASK 65535))
(PUTPROPS \\INVALIDATEDISPLAYCACHE MACRO ((DISPLAYDATA) (* |This| |marks| |the| |character-printing| 
|caches| |of| |the| |displaystream| |as| |invalid.| |Needed| |when| |the| |font| |or| Y |position| 
|changes|) (|freplace| (\\DISPLAYDATA DDCHARSET) |of| DISPLAYDATA |with| MAX.SMALLP) (|freplace| (
\\DISPLAYDATA DDCHARSETASCENT) |of| DISPLAYDATA |with| MAX.SMALLP)))
(PUTPROPS \\DSPGETCHARWIDTH MACRO ((CHARCODE DD) (\\FGETWIDTH (|ffetch| (\\DISPLAYDATA DDWIDTHSCACHE) 
|of| DD) CHARCODE)))
(PUTPROPS \\DSPGETCHARIMAGEWIDTH MACRO ((CHARCODE DD) (\\FGETIMAGEWIDTH (|ffetch| (\\DISPLAYDATA 
DDCHARIMAGEWIDTHS) |of| DD) CHARCODE)))
(PUTPROPS \\DSPGETCHAROFFSET MACRO ((CHARCODE DD) (\\GETBASE (|ffetch| (\\DISPLAYDATA DDOFFSETSCACHE) 
|of| DD) CHARCODE)))
(PUTPROPS \\CONVERTOP MACRO ((OP) (* |rrb| "14-NOV-80 11:14") (* |Only| |for| |alto| |bitblt| !!) (
SELECTQ OP (|replace| 0 |of| NIL |with| NIL) (PAINT 1) (INVERT 2) (ERASE 3) 0)))
(PUTPROPS |\\SFInvert| MACRO ((|BitMap| \y) (* |corrects| |for| |the| |fact| |that| |alto| |bitmaps| 
|are| |stored| |with| 0\,0 |as| |upper| |left| |while| |lisp| |bitmaps| |have| 0\,0 |as| |lower| 
|left.| |The| |correction| |is| |actually| |off| |by| |one| (|greater|) |because| \a |majority| |of| 
|the| |places| |that| |it| |is| |called| |actually| |need| |one| |more| |than| |corrected| Y |value.|)
 (IDIFFERENCE (|fetch| (BITMAP BITMAPHEIGHT) |of| |BitMap|) \y)))
(PUTPROPS |\\SFReplicate| MACRO (LAMBDA (|pattern|) (LOGOR |pattern| (LLSH |pattern| 8) (SETQ 
|pattern| (LLSH |pattern| 4)) (LLSH |pattern| 8))))
(PUTPROPS \\SETPBTFUNCTION MACRO (OPENLAMBDA (BBT |SourceType| |Operation|) (PROGN (|replace| (
PILOTBBT PBTOPERATION) |of| BBT |with| (SELECTQ |Operation| (ERASE 1) (PAINT 2) (INVERT 3) 0)) (
|replace| (PILOTBBT PBTSOURCETYPE) |of| BBT |with| (COND ((EQ (EQ |SourceType| (QUOTE INVERT)) (EQ 
|Operation| (QUOTE ERASE))) 0) (T 1))))))
(PUTPROPS \\BITBLT1 MACRO ((|bbt|) (|BitBltSUBR| |bbt|)))
(PUTPROP (QUOTE BITBLT) (QUOTE MACRO) (QUOTE (= . BKBITBLT)))
(PROGN (PUTPROPS \\INSURETOPWDS DMACRO (OPENLAMBDA (DS) (OR (EQ DS \\TOPWDS) (COND ((FMEMB (
DSPDESTINATION NIL DS) \\SCREENBITMAPS) (\\TOTOPWDS DS)))))) (PUTPROPS \\INSURETOPWDS MACRO ((DS) (* 
|For| |non-window| |implementations|) (PROGN))))
(PUTPROPS .WHILE.TOP.DS. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* FIRST |should| 
|be| \a |displaystream| |and| \a |variable.| |This| |macro| |may| |also| |take| \a |soft| |cursor| 
|down,| |similar| |to| |the| |way| .WHILE.CURSOR.DOWN. |does,| |but| |only| |if| |FIRST's| 
|destination| |is| |the| |same| |as| |the| |soft| |cursor's| |destination.| *) (COND (\\SOFTCURSORP (
SETQ SOFTCURSORUP (AND \\SOFTCURSORUPP (EQ (DSPDESTINATION NIL FIRST) \\CURSORDESTINATION))) (COND (
SOFTCURSORUP (SETQ DISPINTERRUPT (\\GETBASE \\EM.DISPINTERRUPT 0)) (\\PUTBASE \\EM.DISPINTERRUPT 0 0) 
(\\SOFTCURSORDOWN))))) (\\INSURETOPWDS FIRST) (PROGN . REST) (COND (SOFTCURSORUP (
\\SOFTCURSORUPCURRENT) (\\PUTBASE \\EM.DISPINTERRUPT 0 DISPINTERRUPT))))))
(PUTPROPS .WHILE.CURSOR.DOWN. MACRO ((FIRST . REST) (PROG (DISPINTERRUPT SOFTCURSORUP) (* |This| 
|macro| |should| |wrap| |around| |any| |code| |that| |draws| |or| |bitblts| |directly| |from| |or| 
|to| \a |screen| |bitmap.| E.\g. DRAWGRAYBOX |in| HLDISPLAY |which| |puts| |up| \a |shadow| |box| 
|during| GETREGION. |The| |purpose| |of| |this| |macro| |is| |that| \a |soft| (|e.g.| |color|) 
|cursor's| |bits| |not| |be| |taken| |to| |be| |screen| |bits| |while| FIRST & REST |are| |done.| *) (
COND (\\SOFTCURSORP (SETQ SOFTCURSORUP \\SOFTCURSORUPP) (COND (SOFTCURSORUP (SETQ DISPINTERRUPT (
\\GETBASE \\EM.DISPINTERRUPT 0)) (\\PUTBASE \\EM.DISPINTERRUPT 0 0) (\\SOFTCURSORDOWN))))) (PROGN 
FIRST . REST) (COND (SOFTCURSORUP (\\SOFTCURSORUPCURRENT) (\\PUTBASE \\EM.DISPINTERRUPT 0 
DISPINTERRUPT))))))
(ADDTOVAR GLOBALVARS \\TOPWDS)
(DEFOPTIMIZER TTYDISPLAYSTREAM (&REST X) (COND ((NULL (CAR X)) (QUOTE \\TERM.OFD)) (T (QUOTE 
IGNOREMACRO))))
(GLOBALVARS BELLCNT BELLRATE TTYBACKGROUNDFNS |\\DisplayStoppedForLogout| \\CARET.UP)
(PUTPROPS \\CHECKCARET MACRO ((X) (AND \\CARET.UP (\\CARET.DOWN X))))
(PUTPROPS \\DSPTRANSFORMX MACRO ((X DD) (* |transforms| |an| \x |coordinate| |into| |the| 
|destination| |coordinate.|) (IPLUS X (|fetch| (\\DISPLAYDATA DDXOFFSET) |of| DD))))
(PUTPROPS \\DSPTRANSFORMY MACRO ((Y DD) (* |transforms| |an| \y |coordinate| |into| |the| 
|destination| |coordinate.|) (IPLUS Y (|fetch| (\\DISPLAYDATA DDYOFFSET) |of| DD))))
(PUTPROPS \\OFFSETBOTTOM MACRO ((X) (* |gives| |the| |destination| |coordinate| |address| |of| |the| 
|origin.|) (|fetch| (\\DISPLAYDATA DDYOFFSET) |of| X)))
(PUTPROPS \\OFFSETLEFT MACRO ((DD) (* |returns| |the| \x |origin| |of| |display| |data| |destination| 
|coordinates.|) (|fetch| (\\DISPLAYDATA DDXOFFSET) |of| DD)))
(PUTPROPS DISPLAYINITIALIZEDP MACRO (NIL (* |always| |initialized| |now|) T))
(PUTPROPS DISPLAYSTARTEDP MACRO (NIL |\\DisplayStarted|))
(GLOBALVARS |\\DisplayStarted| |\\DisplayStreamsInitialized| |\\DisplayInitialed| WHOLEDISPLAY 
WHOLESCREEN SCREENWIDTH SCREENHEIGHT)
(PUTPROP (QUOTE LLDISPLAY) (QUOTE IMPORTDATE) (IDATE "18-Apr-1994 00:20:42"))

(RECORD REGION (LEFT BOTTOM WIDTH HEIGHT) LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767 (
ACCESSFNS ((TOP (IPLUS (|fetch| (REGION BOTTOM) |of| DATUM) (|fetch| (REGION HEIGHT) |of| DATUM) -1)) 
(PTOP (IPLUS (|fetch| (REGION BOTTOM) |of| DATUM) (|fetch| (REGION HEIGHT) |of| DATUM))) (RIGHT (IPLUS
 (|fetch| (REGION LEFT) |of| DATUM) (|fetch| (REGION WIDTH) |of| DATUM) -1)) (PRIGHT (IPLUS (|fetch| (
REGION LEFT) |of| DATUM) (|fetch| (REGION WIDTH) |of| DATUM))))) (TYPE? (AND (EQLENGTH DATUM 4) (EVERY
 DATUM (FUNCTION NUMBERP)))) (SYSTEM))
(DATATYPE BITMAP ((BITMAPBASE POINTER) (BITMAPRASTERWIDTH WORD) (BITMAPHEIGHT WORD) (BITMAPWIDTH WORD)
 (BITMAPBITSPERPIXEL WORD)) BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((|BitMapHiLoc| WORD) (
|BitMapLoLoc| WORD)) (* \; "overlay initial pointer")) (SYSTEM))
(BLOCKRECORD BITMAPWORD ((BITS WORD)) (SYSTEM))
(RECORD POSITION (XCOORD . YCOORD) (TYPE? (AND (LISTP DATUM) (NUMBERP (CAR DATUM)) (NUMBERP (CDR DATUM
)))) (SYSTEM))
(DATATYPE CURSOR (CUIMAGE CUMASK CUHOTSPOTX CUHOTSPOTY CUDATA) (ACCESSFNS ((CUBITSPERPIXEL (|fetch| (
BITMAP BITMAPBITSPERPIXEL) |of| (|fetch| (CURSOR CUIMAGE) |of| DATUM))))) (SYSTEM))
(RECORD MOUSEEVENT (MOUSEX MOUSEY MOUSEBUTTONS KEYBOARD MOUSETIME) (SYSTEM))
(RECORD SCREENREGION (SCREEN . REGION) (SUBRECORD REGION) (TYPE? (AND (LISTP DATUM) (|type?| SCREEN (
CAR DATUM)) (|type?| REGION (CDR DATUM)))) (SYSTEM))
(RECORD SCREENPOSITION (SCREEN . POSITION) (SUBRECORD POSITION) (TYPE? (AND (LISTP DATUM) (|type?| 
SCREEN (CAR DATUM)) (|type?| POSITION (CDR DATUM)))) (SYSTEM))
(PUTPROPS CURSORBITMAP MACRO (NIL |CursorBitMap|))
(RPAQQ HARDCURSORHEIGHT 16)
(RPAQQ HARDCURSORWIDTH 16)
(CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16))
(ADDTOVAR GLOBALVARS |CursorBitMap|)
(ARRAYRECORD POLYNOMIAL (A B C D) (CREATE (ARRAY 4 (QUOTE FLOATP))) (SYSTEM))
(RECORD SPLINE (\#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY))
(PUTPROPS HALF MACRO ((X) (LRSH X 1)))
(PUTPROPS \\FILLCIRCLEBLT MACRO (OPENLAMBDA (CX CY X Y) (* \; 
"calls bitblt twice to fill in one line of the circle.") (\\LINEBLT FCBBT (IDIFFERENCE CX X) (IPLUS CY
 Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS
) (\\LINEBLT FCBBT (IDIFFERENCE CX X) (IDIFFERENCE CY Y) (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT
 RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)))
(PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (VARS . X))))))
(PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (E (MAPC (QUOTE X) (QUOTE 
PRINTCURSOR))))))))
(ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH |ScreenBitMap|)
(RPAQQ BLACKSHADE 65535)
(RPAQQ WHITESHADE 0)
(CONSTANTS (BLACKSHADE 65535) (WHITESHADE 0))
(RPAQQ GRAYSHADE 43605)
(ADDTOVAR GLOBALVARS GRAYSHADE)
(RECORD HLS (HUE LIGHTNESS SATURATION))
(RECORD RGB (RED GREEN BLUE))
(PUTPROP (QUOTE ADISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Sep-1994 17:07:04"))

(ADDTOVAR SYSSPECVARS \\INTERRUPTABLE)
(PUTPROPS UNINTERRUPTABLY INFO EVAL)
(PUTPROPS UNINTERRUPTABLY DMACRO ((X . Y) ((LAMBDA (\\INTERRUPTABLE) (PROGN X . Y)) NIL)))
(ADDTOVAR PRETTYPRINTMACROS (UNINTERRUPTABLY LAMBDA (FORM) (PROG ((POS (IPLUS 4 (POSITION)))) (PRIN1 
"(") (PRIN2 (CAR FORM)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM (CDR FORM)))) (TAB POS 0)) (PRINTDEF FORM 
POS T T FNSLST) (PRIN1 ")"))))
(BLOCKRECORD INTERRUPTSTATE ((* |;;| 
"This is the structure used to communicate between the emulator and Lisp re interrupts.  There is a bit per interrupt type, plus space for the character code that caused a keyboard interrupt."
) (* |;;| "This must match the INTSTAT definition in lispemul.h") (* |;;| "PENDING-INTERRUPT FLAGS:") 
(LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.") (ETHERINTERRUPT FLAG) (* \; 
"Ether packet read finished.") (IOINTERRUPT FLAG) (GCDISABLED FLAG) (* \; "No mroe room in GC tables."
) (VMEMFULL FLAG) (* \; "VMEM is full!!") (STACKOVERFLOW FLAG) (* \; "Stack overflowed.") (STORAGEFULL
 FLAG) (* \; "Ran out of storage, atoms, etc.") (WAITINGINTERRUPT FLAG) (* |;;| 
"INTERRUPTS-IN-PROCESS MASK:") (P-LOGMSGSPENDING FLAG) (* \; " Log/Console msgs need printing.") (
P-ETHERINTERRUPT FLAG) (* \; "Ether packet read finished.") (P-IOINTERRUPT FLAG) (P-GCDISABLED FLAG) (
* \; "No mroe room in GC tables.") (P-VMEMFULL FLAG) (* \; "VMEM is full!!") (P-STACKOVERFLOW FLAG) (*
 \; "Stack overflowed.") (P-STORAGEFULL FLAG) (* \; "Ran out of storage, atoms, etc.") (
P-WAITINGINTERRUPT FLAG) (INTCHARCODE WORD)) (BLOCKRECORD INTERRUPTSTATE ((* |;;| 
"Alternative view of the structure:") (PENDING BITS 8) (* \; "Pending-interrupt flags") (IN-PROGRESS 
BITS 8) (* \; "Mask to prevent re-interrupt for an interrupt in progress") (NIL WORD))))
(PUTPROPS \\TAKEINTERRUPT DMACRO ((PREFORM POSTFORM) (DECLARE (GLOBALVARS \\PENDINGINTERRUPT)) (COND (
(AND \\PENDINGINTERRUPT (INTERRUPTABLE~=NILUPTHESTACK)) PREFORM ((LAMBDA (\\INTERRUPTABLE) (
\\CALLINTERRUPTED)) T) POSTFORM))))
(PUTPROP (QUOTE AINTERRUPT) (QUOTE IMPORTDATE) (IDATE "17-Sep-1992 10:42:38"))

(ACCESSFNS PUP ((PUPBASE (LOCF (|fetch| (ETHERPACKET EPBODY) |of| DATUM)))) (BLOCKRECORD PUPBASE ((
PUPLENGTH WORD) (PUPTCONTROL BYTE) (PUPTYPE BYTE) (PUPID FIXP) (PUPDEST WORD) (PUPDESTSOCKET FIXP) (
PUPSOURCE WORD) (PUPSOURCESOCKET FIXP) (PUPDATASTART 266 WORD)) (BLOCKRECORD PUPBASE ((NIL WORD) (
TYPEWORD WORD) (PUPIDHI WORD) (PUPIDLO WORD) (PUPDESTNET BYTE) (PUPDESTHOST BYTE) (PUPDESTSOCKETHI 
WORD) (PUPDESTSOCKETLO WORD) (PUPSOURCENET BYTE) (PUPSOURCEHOST BYTE) (PUPSOURCESOCKETHI WORD) (
PUPSOURCESOCKETLO WORD)) (* \; "Temporary extra synonyms") (SYNONYM PUPDESTNET (DESTNET)) (SYNONYM 
PUPDESTHOST (DESTHOST)) (SYNONYM PUPDESTSOCKETHI (DESTSKTHI)) (SYNONYM PUPDESTSOCKETLO (DESTSKTLO)) (
SYNONYM PUPSOURCENET (SOURCENET)) (SYNONYM PUPSOURCEHOST (SOURCEHOST)) (SYNONYM PUPSOURCESOCKETHI (
SOURCESKTHI)) (SYNONYM PUPSOURCESOCKETLO (SOURCESKTLO))) (SYNONYM PUPDEST (DEST)) (SYNONYM 
PUPDESTSOCKET (DESTSKT)) (SYNONYM PUPSOURCE (SOURCE)) (SYNONYM PUPSOURCESOCKET (SOURCESKT)) (ACCESSFNS
 PUPDATASTART ((PUPCONTENTS (LOCF DATUM))))) (ACCESSFNS PUP ((PUPCHECKSUMBASE (|fetch| PUPBASE |of| 
DATUM)) (PUPCHECKSUMLOC (\\ADDBASE (|fetch| PUPBASE |of| DATUM) (FOLDLO (SUB1 (|fetch| PUPLENGTH |of| 
DATUM)) BYTESPERWORD)))) (BLOCKRECORD PUPCHECKSUMLOC ((PUPCHECKSUM WORD)))) (TYPE? (|type?| 
ETHERPACKET DATUM)))
(ACCESSFNS PUPADDRESS ((PUPNET# (LRSH DATUM 8)) (PUPHOST# (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH 
PUPNET# 8) PUPHOST#)))
(PUTPROPS \\LOCALPUPADDRESS MACRO (NIL \\LOCALPUPNETHOST))
(PUTPROPS \\LOCALPUPHOSTNUMBER MACRO (NIL (|fetch| PUPHOST# |of| \\LOCALPUPNETHOST)))
(PUTPROPS \\LOCALPUPNETNUMBER MACRO (NIL (|fetch| PUPNET# |of| \\LOCALPUPNETHOST)))
(ACCESSFNS ERRORPUP ((ERRORPUPBASE (|fetch| PUPCONTENTS |of| DATUM))) (BLOCKRECORD ERRORPUPBASE ((
ERRORPUPCOPY 10 WORD) (* \; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* \; 
"Usually zero") (ERRORPUPSTRINGBASE WORD) (* \; "Human readable message"))))
(RPAQQ PUPERRORCODES ((\\PUPE.CHECKSUM 1) (\\PUPE.NOSOCKET 2) (\\PUPE.SOCKETFULL 3) (
\\PUPE.GATEWAY.BADPUP 513) (\\PUPE.NOROUTE 514) (\\PUPE.NOHOST 515) (\\PUPE.LOOPED 516) (
\\PUPE.TOOLARGE 517) (\\PUPE.WRONG.GATEWAY 518) (\\PUPE.GATEWAYFULL 519)))
(RPAQQ \\PUPE.CHECKSUM 1)
(RPAQQ \\PUPE.NOSOCKET 2)
(RPAQQ \\PUPE.SOCKETFULL 3)
(RPAQQ \\PUPE.GATEWAY.BADPUP 513)
(RPAQQ \\PUPE.NOROUTE 514)
(RPAQQ \\PUPE.NOHOST 515)
(RPAQQ \\PUPE.LOOPED 516)
(RPAQQ \\PUPE.TOOLARGE 517)
(RPAQQ \\PUPE.WRONG.GATEWAY 518)
(RPAQQ \\PUPE.GATEWAYFULL 519)
(CONSTANTS (\\PUPE.CHECKSUM 1) (\\PUPE.NOSOCKET 2) (\\PUPE.SOCKETFULL 3) (\\PUPE.GATEWAY.BADPUP 513) (
\\PUPE.NOROUTE 514) (\\PUPE.NOHOST 515) (\\PUPE.LOOPED 516) (\\PUPE.TOOLARGE 517) (
\\PUPE.WRONG.GATEWAY 518) (\\PUPE.GATEWAYFULL 519))
(PUTPROPS BINDPUPS MACRO (X (CONS (LIST (QUOTE LAMBDA) (CAR X) (CONS (QUOTE PROGN) (CDR X))) (|in| (
CAR X) |collect| (LIST (QUOTE ALLOCATE.PUP))))))
(PUTPROPS BINDPUPS INFO BINDS)
(ADDTOVAR PRETTYPRINTMACROS (BINDPUPS LAMBDA (FORM) (PROG ((POS (IPLUS 2 (POSITION)))) (PRIN1 "(") (
PRIN2 (CAR FORM)) (SPACES 1) (PRINTDEF (CADR FORM) (POSITION)) (OR (EQ COMMENTFLG (CAAR (SETQ FORM (
CDDR FORM)))) (TAB POS 0)) (PRINTDEF FORM POS T T FNSLST) (PRIN1 ")"))))
(BLOCKRECORD PORT ((NETHOST WORD) (SOCKET FIXP)) (BLOCKRECORD PORT ((NET BYTE) (HOST BYTE) (SOCKETHI 
WORD) (SOCKETLO WORD))))
(ACCESSFNS ERRORPUP ((ERRORPUPBASE (|fetch| PUPCONTENTS |of| DATUM))) (BLOCKRECORD ERRORPUPBASE ((
ERRORPUPCOPY 10 WORD) (* \; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* \; 
"Usually zero") (ERRORPUPSTRINGBASE WORD) (* \; "Human readable message"))))
(GLOBALVARS \\ETHERWAIT1 \\ETHERTIMEOUT \\MAXETHERTRIES PUPTRACEFLG LOGINPASSWORDS)
(GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS)
(RPAQQ \\PUPOVLEN 22)
(RPAQQ \\MAX.PUPLENGTH 532)
(RPAQQ \\TIME.GETPUP 5)
(CONSTANTS (\\PUPOVLEN 22) (\\MAX.PUPLENGTH 532) (\\TIME.GETPUP 5))
(PUTPROPS PUPPRINTMACROS VARTYPE ALIST)
(PUTPROPS \\GETPUPWORD DMACRO ((PUP WORD#) (\\GETBASE (|fetch| PUPCONTENTS |of| PUP) WORD#)))
(PUTPROPS \\PUTPUPWORD DMACRO ((PUP WORD# VALUE) (\\PUTBASE (|fetch| PUPCONTENTS |of| PUP) WORD# VALUE
)))
(PUTPROPS \\GETPUPBYTE DMACRO ((PUP BYTE#) (\\GETBASEBYTE (|fetch| PUPCONTENTS |of| PUP) BYTE#)))
(PUTPROPS \\PUTPUPBYTE DMACRO ((PUP BYTE# VALUE) (\\PUTBASEBYTE (|fetch| PUPCONTENTS |of| PUP) BYTE# 
VALUE)))
(RPAQQ RAWPUPTYPES ((\\PT.ECHOME 1) (\\PT.IAMECHO 2) (\\PT.IAMBADECHO 3) (\\PT.ERROR 4) (\\PT.RFC 8) (
\\PT.ABORT 9) (\\PT.END 10) (\\PT.ENDREPLY 11) (\\PT.DATA 16) (\\PT.ADATA 17) (\\PT.ACK 18) (\\PT.MARK
 19) (\\PT.INTERRUPT 20) (\\PT.INTERRUPTREPLY 21) (\\PT.AMARK 22) (\\PT.GATEWAYREQUEST 128) (
\\PT.GATEWAYRESPONSE 129) (\\PT.ALTOTIMEREQUEST 134) (\\PT.ALTOTIMERESPONSE 135) (\\PT.MSGCHECK 136) (
\\PT.NEWMAIL 137) (\\PT.NONEWMAIL 138) (\\PT.NOMAILBOX 139) (\\PT.LAURELCHECK 140) (\\PT.NAMELOOKUP 
144) (\\PT.NAMERESPONSE 145) (\\PT.NAME/ADDRERROR 146) (\\PT.ADDRLOOKUP 147) (\\PT.ADDRRESPONSE 148) (
\\PT.PRINTERSTATUS 128) (\\PT.STATUSRESPONSE 129) (\\PT.PRINTERCAPABILITY 130) (
\\PT.CAPABILITYRESPONSE 131) (\\PT.PRINTJOBSTATUS 132) (\\PT.PRINTJOBRESPONSE 133)))
(RPAQQ \\PT.ECHOME 1)
(RPAQQ \\PT.IAMECHO 2)
(RPAQQ \\PT.IAMBADECHO 3)
(RPAQQ \\PT.ERROR 4)
(RPAQQ \\PT.RFC 8)
(RPAQQ \\PT.ABORT 9)
(RPAQQ \\PT.END 10)
(RPAQQ \\PT.ENDREPLY 11)
(RPAQQ \\PT.DATA 16)
(RPAQQ \\PT.ADATA 17)
(RPAQQ \\PT.ACK 18)
(RPAQQ \\PT.MARK 19)
(RPAQQ \\PT.INTERRUPT 20)
(RPAQQ \\PT.INTERRUPTREPLY 21)
(RPAQQ \\PT.AMARK 22)
(RPAQQ \\PT.GATEWAYREQUEST 128)
(RPAQQ \\PT.GATEWAYRESPONSE 129)
(RPAQQ \\PT.ALTOTIMEREQUEST 134)
(RPAQQ \\PT.ALTOTIMERESPONSE 135)
(RPAQQ \\PT.MSGCHECK 136)
(RPAQQ \\PT.NEWMAIL 137)
(RPAQQ \\PT.NONEWMAIL 138)
(RPAQQ \\PT.NOMAILBOX 139)
(RPAQQ \\PT.LAURELCHECK 140)
(RPAQQ \\PT.NAMELOOKUP 144)
(RPAQQ \\PT.NAMERESPONSE 145)
(RPAQQ \\PT.NAME/ADDRERROR 146)
(RPAQQ \\PT.ADDRLOOKUP 147)
(RPAQQ \\PT.ADDRRESPONSE 148)
(RPAQQ \\PT.PRINTERSTATUS 128)
(RPAQQ \\PT.STATUSRESPONSE 129)
(RPAQQ \\PT.PRINTERCAPABILITY 130)
(RPAQQ \\PT.CAPABILITYRESPONSE 131)
(RPAQQ \\PT.PRINTJOBSTATUS 132)
(RPAQQ \\PT.PRINTJOBRESPONSE 133)
(CONSTANTS (\\PT.ECHOME 1) (\\PT.IAMECHO 2) (\\PT.IAMBADECHO 3) (\\PT.ERROR 4) (\\PT.RFC 8) (
\\PT.ABORT 9) (\\PT.END 10) (\\PT.ENDREPLY 11) (\\PT.DATA 16) (\\PT.ADATA 17) (\\PT.ACK 18) (\\PT.MARK
 19) (\\PT.INTERRUPT 20) (\\PT.INTERRUPTREPLY 21) (\\PT.AMARK 22) (\\PT.GATEWAYREQUEST 128) (
\\PT.GATEWAYRESPONSE 129) (\\PT.ALTOTIMEREQUEST 134) (\\PT.ALTOTIMERESPONSE 135) (\\PT.MSGCHECK 136) (
\\PT.NEWMAIL 137) (\\PT.NONEWMAIL 138) (\\PT.NOMAILBOX 139) (\\PT.LAURELCHECK 140) (\\PT.NAMELOOKUP 
144) (\\PT.NAMERESPONSE 145) (\\PT.NAME/ADDRERROR 146) (\\PT.ADDRLOOKUP 147) (\\PT.ADDRRESPONSE 148) (
\\PT.PRINTERSTATUS 128) (\\PT.STATUSRESPONSE 129) (\\PT.PRINTERCAPABILITY 130) (
\\PT.CAPABILITYRESPONSE 131) (\\PT.PRINTJOBSTATUS 132) (\\PT.PRINTJOBRESPONSE 133))
(RPAQ? PUPTYPES RAWPUPTYPES)
(RPAQQ WELLKNOWNPUPSOCKETS ((\\PUPSOCKET.TELNET 1) (\\PUPSOCKET.ROUTING 2) (\\PUPSOCKET.FTP 3) (
\\PUPSOCKET.MISCSERVICES 4) (\\PUPSOCKET.ECHO 5) (\\PUPSOCKET.EFTP 16) (\\PUPSOCKET.PRINTERSTATUS 17) 
(\\PUPSOCKET.LEAF 35)))
(RPAQQ \\PUPSOCKET.TELNET 1)
(RPAQQ \\PUPSOCKET.ROUTING 2)
(RPAQQ \\PUPSOCKET.FTP 3)
(RPAQQ \\PUPSOCKET.MISCSERVICES 4)
(RPAQQ \\PUPSOCKET.ECHO 5)
(RPAQQ \\PUPSOCKET.EFTP 16)
(RPAQQ \\PUPSOCKET.PRINTERSTATUS 17)
(RPAQQ \\PUPSOCKET.LEAF 35)
(CONSTANTS (\\PUPSOCKET.TELNET 1) (\\PUPSOCKET.ROUTING 2) (\\PUPSOCKET.FTP 3) (
\\PUPSOCKET.MISCSERVICES 4) (\\PUPSOCKET.ECHO 5) (\\PUPSOCKET.EFTP 16) (\\PUPSOCKET.PRINTERSTATUS 17) 
(\\PUPSOCKET.LEAF 35))
(PUTPROP (QUOTE PUP) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 11:14:09"))

(PUTPROPS UNLESSRDSYS MACRO ((NORMAL RDSYS) NORMAL))
(PUTPROPS UNLESSINEW MACRO ((NORMAL I-NEW) NORMAL))
(PUTPROPS 1ST MACRO ((A . B) A))
(PUTPROPS 2ND MACRO ((A B . C) B))
(PUTPROPS LOCAL MACRO ((X) X))
(PUTPROPS ALLOCAL MACRO ((X) X))
(PUTPROPS ADDBASE DMACRO (= . \\ADDBASE))
(PUTPROPS GETBASE DMACRO (= . \\GETBASE))
(PUTPROPS GETBASEBYTE DMACRO (= . \\GETBASEBYTE))
(PUTPROPS GETBASEPTR DMACRO (= . \\GETBASEPTR))
(PUTPROPS HILOC DMACRO (= . \\HILOC))
(PUTPROPS LOLOC DMACRO (= . \\LOLOC))
(PUTPROPS PUTBASE DMACRO (= . \\PUTBASE))
(PUTPROPS PUTBASEBYTE DMACRO (= . \\PUTBASEBYTE))
(PUTPROPS PUTBASEPTR DMACRO (= . \\PUTBASEPTR))
(PUTPROPS REPLACEPTRFIELD DMACRO (= . \\RPLPTR))
(PUTPROPS VAG2 DMACRO (= . \\VAG2))
(PUTPROPS PAGEBASE MACRO ((PTR) (|fetch| (POINTER PAGEBASE) |of| PTR)))
(PUTPROPS PAGELOC MACRO (OPENLAMBDA (PTR) (IPLUS (LLSH (\\HILOC PTR) 8) (LRSH (\\LOLOC PTR) 8))))
(PUTPROP (QUOTE RENAMEMACROS) (QUOTE IMPORTDATE) (IDATE "27-Apr-1994 15:43:27"))

(PUTPROPS MOUSESTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR 
ARGS) T))))
(PUTPROPS LASTMOUSESTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS) T)))
(PUTPROPS UNTILMOUSESTATE MACRO (ARGS (COND ((AND (CDR ARGS) (CADR ARGS) (NEQ (CADR ARGS) T)) (* 
|time| |argument| |is| |given| |and| |is| |not| T |or| NIL\; |compile| |in| |time| |keeping| |loop.|) 
(LIST (QUOTE PROG) (LIST (LIST (QUOTE TIMEOUT) (LIST (QUOTE IPLUS) (QUOTE (CLOCK 0)) (LIST (QUOTE OR) 
(LIST (QUOTE NUMBERP) (CADR ARGS)) 100))) (QUOTE (NOWTIME (CLOCK 0)))) (QUOTE LP) (LIST (QUOTE COND) (
LIST (CONS (QUOTE MOUSESTATE) (LIST (CAR ARGS) T)) (QUOTE (RETURN T)))) (QUOTE (COND ((IGREATERP (
CLOCK0 NOWTIME) TIMEOUT) (RETURN NIL)) (T (\\BACKGROUND)))) (QUOTE (GO LP)))) (T (LIST (QUOTE PROG) 
NIL (QUOTE LP) (LIST (QUOTE COND) (LIST (CONS (QUOTE MOUSESTATE) (LIST (CAR ARGS) T)) (QUOTE (RETURN T
)))) (QUOTE (\\BACKGROUND)) (QUOTE (GO LP)))))))
(PUTPROPS KEYSETSTATE MACRO (ARGS (LIST (QUOTE PROGN) (QUOTE (GETMOUSESTATE)) (MOUSESTATE-EXPR (CAR 
ARGS)))))
(PUTPROPS LASTKEYSETSTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS))))
(PUTPROPS WITHIN MACRO ((A B C) (AND (IGEQ A B) (ILESSP A (IPLUS B C)))))
(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS)
(PUTPROPS IABS MACRO (OPENLAMBDA (A) (COND ((IGEQ A 0) A) (T (IMINUS A)))))
(PUTPROP (QUOTE HLDISPLAY) (QUOTE IMPORTDATE) (IDATE "15-Mar-1994 10:48:02"))

(PUTPROPS .COPYKEYDOWNP. MACRO (NIL (OR (KEYDOWNP (QUOTE LSHIFT)) (KEYDOWNP (QUOTE RSHIFT)) (KEYDOWNP 
(QUOTE COPY)))))
(PUTPROPS WSOP MACRO (ARGS (LET ((METHOD (CADR (CAR ARGS))) (DISPLAY (CADR ARGS)) (OTHERARGS (CDDR 
ARGS))) (BQUOTE (SPREADAPPLY* (|fetch| (WSOPS (\\\, METHOD)) |of| (|fetch| (FDEV WINDOWOPS) |of| (\\\,
 DISPLAY))) (\\\, DISPLAY) (\\\,@ OTHERARGS))))))
(PUTPROPS \\COERCETODS MACRO (OPENLAMBDA (X) (COND ((|type?| WINDOW X) (|fetch| (WINDOW DSP) |of| X)) 
(T (\\ILLEGAL.ARG X)))))
(PUTPROPS .WHILE.ON.TOP. MACRO ((FIRST . REST) (UNINTERRUPTABLY (\\INTERNALTOTOPW FIRST) . REST)))
(PUTPROPS WINDOWOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS
))) (COND ((AND (LISTP OPNAME) (EQ (CAR OPNAME) (QUOTE QUOTE))) (BQUOTE (SPREADAPPLY* (|fetch| (SCREEN
 (\\\, (CADR OPNAME))) |of| (\\\, METHOD-DEVICE)) (\\\, METHOD-DEVICE) (\\\,@ TAIL)))) (T (ERROR 
"OPNAME not quoted: " OPNAME))))))
(RPAQQ |MinWindowWidth| 26)
(RPAQQ |MinWindowHeight| 16)
(CONSTANTS (|MinWindowWidth| 26) (|MinWindowHeight| 16))
(DATATYPE WINDOW (DSP (* \; "The display stream you use to actually printto the window.") NEXTW (* \; 
"Next window in the open-window list") SAVE (* \; "Saved image from anything this window's on top of")
 REG (* \; "Screen region this window occupies") BUTTONEVENTFN (* \; 
"FN called when left/middle mouse button goes up/down") RIGHTBUTTONFN (* \; 
"FN called when right mouse button goes up/down") CURSORINFN (* \; 
"Fn called when mouse enters window") CURSOROUTFN (* \; "Called when mouse leaves window") 
CURSORMOVEDFN (* \; "Called when mouse moves in window") REPAINTFN (* \; 
"Redisplay part of thie window") RESHAPEFN (* \; "Called when window is reshaped") EXTENT (* \; 
"Scrolling limits") USERDATA (* \; "Proplist to hold other window properites") VERTSCROLLREG (* \; 
"Region of vert scroll bar") HORIZSCROLLREG (* \; "Tegion of horiz scroll bar") SCROLLFN (* \; 
"Fn to scroll this window") VERTSCROLLWINDOW (* \; "Vert scroll bar") HORIZSCROLLWINDOW (* \; 
"Horiz scroll bar") CLOSEFN (* \; "Called at close time") MOVEFN (* \; "Called when window is moved") 
WTITLE (* \; "Window's title string, if any") NEWREGIONFN (* \; "Called to get new window shape") 
WBORDER (* \; "Window border-width, in pixels") PROCESS (* \; 
"Medley process associated with this window") WINDOWENTRYFN (* \; 
"Fn to call when kbd focus is switched here") SCREEN (* \; "Screen this window appears on") (
NATIVE-HANDLE FIXP) (* \; 
"Uniterpreted place for native window to store a C pointer to its private info") (NATIVE-INFO1 FIXP) (
* \; "Reserved in case the pointer must be 64 bits") (NATIVE-W1 WORD) (* \; 
"Word for use by native handler") (NATIVE-W2 WORD) (* \; "Word for use by native handler") (NATIVE-P1 
POINTER) (* \; "Lisp pointer for use by native handler")) BUTTONEVENTFN _ (FUNCTION TOTOPW) WBORDER _ 
|WBorder| WINDOWENTRYFN _ (FUNCTION GIVE.TTY.PROCESS) (SYSTEM))
(DATATYPE SCREEN (SCONOFF SCDESTINATION SCWIDTH SCHEIGHT SCTOPW SCTOPWDS SCTITLEDS SCFDEV SCDS SCDATA 
(* |;;| "Space for native window manager interface to use.") (HANDLE FIXP) (* \; 
"Handle for emulator to store info about display for C code use.") (HANDLE2 FIXP) (* \; 
"Reserved in case HANDLE needs to be 64 bits on the C side.") (NATIVE-INFO POINTER) (* \; 
"POINTER for the private use of the emulator window code") NATIVETYPE (* \; 
"Symbol to tell what kind of native window system we're using.") (* |;;| 
"- - - Functional interface to screen management - - -") WINIMAGEOPS (* \; 
"IMAGEOPS to be used in display streas on this kind of screen") WINFDEV (* \; 
"FDEV for display streams on this screen") CREATEWFN (* \; "Create a window") OPENWFN (* \; 
"Open a window") CLOSEWFN (* \; "Close a window") MOVEWFN (* \; "Move a window") RELMOVEWFN (* \; 
"Move window, relative") SHRINKWFN (* \; "Shrink window to icon") EXPANDWFN (* \; 
"Expand icon to window") SHAPEWFN (* \; "Reshape a window") REDISPLAYFN (* \; 
"Redisplay (part of) a window") GETWINDOWPROPFN (* \; "Get window property value") PUTWINDOWPROPFN (* 
\; "Set window property value") BURYWFN (* \; "Move window behind all others") TOTOPWFN (* \; 
"Move iwindow in front of all others") IMPORTWFN (* \; 
"Take a native window and save its state internally") EXPORTWFN (* \; 
"Take a saved window state and open it on this screen, filling in screen and methods as needed.") 
DESTROYFN (* \; "Destroy this window, for GC finaliszation") SETCURSORFN (* \; 
"Set the cursor for this window.") PROMPTW (* \; "The prompt window for this screen") SHOWGCFN (* \; 
"Show GC indication; called with ON/OFF arg, t=>show gcing status, NIL=>turn off GC indicator.") 
DSPCREATEFN (* \; "Create a displaystream on this screen.") BBTTOWIN (* \; 
"BITBLT from a lisp bitmap to a window") BBTFROMWIN (* \; "BITBLT from a window to a lisp bitmap") 
BBTWINWIN (* \; "BITBLT from a window to another window.") SCCURSOR (* \; 
"CURSOR that's in effect for this screen by default.") SCKEYBOARD (* \; 
"Something about which keyboard we're receiving from.") SCDEPTH (* \; 
"# of bits per pixel on the screen.  THIS WILL REPLACE SCBITSPERPIXEL ASAP.") SCCLOSEDOWN (* \; 
"Close down this screen cleanly, saving window state.") SCCLOSESCREEN (* \; 
"Close down thie screen cleanly, no state saving.") SCREOPEN (* \; "Reopen this screen?") SCCARETFLASH
 (* \; "Function to flash thecaret.") SCGETSCREENPOSITION (* \; "GETSCREENPOSITION") 
SCGETBOXSCREENPOSITION (* \; "GETBOXPOSITION") SCGETSCREENREGION (* \; "GETREGION") SCMOVEPOINTER (* 
\; "\\CURSORPOSITION")) SCONOFF _ (QUOTE OFF) (ACCESSFNS ((SCBITSPERPIXEL (COND ((|fetch| (SCREEN 
SCDESTINATION) |of| DATUM) (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| (|fetch| (SCREEN SCDESTINATION) 
|of| DATUM))) (T 1))) (SCREGION (|create| REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (|fetch| (SCREEN SCWIDTH)
 |of| DATUM) HEIGHT _ (|fetch| (SCREEN SCHEIGHT) |of| DATUM))))) (SYSTEM))
(GLOBALVARS WINDOWUSERFORMS ENDOFWINDOWUSERFORMS PROMPTWINDOW)
(PUTPROP (QUOTE WINDOW) (QUOTE IMPORTDATE) (IDATE " 9-Apr-2000 17:36:29"))

(PUTPROPS NNLITATOM MACRO (OPENLAMBDA (X) (AND X (LITATOM X))))
(PUTPROPS \\NULL.OR.FIXP MACRO (OPENLAMBDA (X) (OR (NULL X) (FIXP X))))
(PUTPROPS \\CHECKTYPE MACRO (X (PROG ((VAR (CAR X)) (PRED (CADR X))) (|if| (AND (LISTP PRED) (MEMB (
CAR PRED) (QUOTE (QUOTE FUNCTION)))) |then| (SETQ PRED (LIST (CADR PRED) VAR))) (RETURN (SUBPAIR (
QUOTE (MSG VAR PRED)) (LIST (CONCAT "
 is not a suitable value for the variable:  " VAR) VAR PRED) (QUOTE (|until| PRED |do| (SETQ VAR (
ERROR VAR MSG)))))))))
(PUTPROPS CANONICAL.TIMERUNITS MACRO (OPENLAMBDA (X) (* |Checks| |for| |common| |abbreviations| 
|before| |calling| |\\CanonicalizeTimerUnits|) (SELECTQ X ((TICKS MILLISECONDS SECONDS) (* |These| 
|are| |the| |canonical| |forms|) X) (NIL (QUOTE MILLISECONDS)) (|\\CanonicalizeTimerUnits| X))))
(PUTPROPS \\MACRO.EVAL DMACRO (Z (PROG ((X (EXPANDMACRO (CAR Z) T))) (|if| (EQ X (CAR Z)) |then| (
ERROR "No macro property -- \\MACRO.EVAL" X) |else| (RETURN (EVAL X))))))
(DEFOPTIMIZER \\MACRO.MX (FORM) FORM)
(PUTPROP (QUOTE MACROAUX) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:26:31"))

(RPAQQ MASK0WORD1\'S 32767)
(RPAQQ MASK1WORD0\'S 32768)
(RPAQQ MASKWORD1\'S 65535)
(RPAQQ MASKHALFWORD1\'S 255)
(RPAQQ BITSPERHALFWORD 8)
(CONSTANTS MASK0WORD1\'S MASK1WORD0\'S MASKWORD1\'S MASKHALFWORD1\'S BITSPERHALFWORD)
(PUTPROPS EQZEROP MACRO ((X) (EQ 0 X)))
(PUTPROPS \\MOVETOBOX DMACRO (OPENLAMBDA (N D) (SELECTC (NTYPX N) (\\SMALLP (|replace| (FIXP HINUM) 
|of| D |with| 0) (|replace| (FIXP LONUM) |of| D |with| N)) (\\FIXP (|replace| (FIXP HINUM) |of| D 
|with| (|fetch| (FIXP HINUM) |of| N)) (|replace| (FIXP LONUM) |of| D |with| (|fetch| (FIXP LONUM) |of|
 N))) (\\ILLEGAL.ARG N))))
(PUTPROPS .XUNBOX. MACRO ((X HX LX) (|until| (SETQ LX (SELECTC (NTYPX X) (\\SMALLP (COND ((IGEQ X 0) (
SETQ HX 0) X) (T (SETQ HX MASKWORD1\'S) (\\LOLOC X)))) (\\FIXP (SETQ HX (|fetch| (FIXP HINUM) |of| X))
 (|fetch| (FIXP LONUM) |of| X)) NIL)) |do| (SETQ X (LISPERROR "ILLEGAL ARG" X T)))))
(PUTPROPS .XLLSH. MACRO ((HI LO N) (|if| (IGEQ N BITSPERWORD) |then| (* \; 
"Jump 16 bits in a single bound!") (SETQ HI LO) (SETQ LO 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) (
|if| (IGEQ N BITSPERHALFWORD) |then| (* \; "Jump 8 bits in a single bound!") (SETQ HI (LOGOR (
.LOHALFWORDHI. HI) (.HIHALFWORDLO. LO))) (SETQ LO (.LOHALFWORDHI. LO)) (SETQ N (IDIFFERENCE N 
BITSPERHALFWORD))) (|if| (IGEQ N 4) |then| (* \; "Jump 4 bits in a single bound!") (SETQ HI (LOGOR (
LRSH LO (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LLSH (LOGAND HI (CONSTANT (MASK.1\'S 0 (IDIFFERENCE 
BITSPERWORD 4)))) 4))) (SETQ LO (LLSH (LOGAND LO (CONSTANT (MASK.1\'S 0 (IDIFFERENCE BITSPERWORD 4))))
 4)) (SETQ N (IDIFFERENCE N 4))) (* \; 
"MASK0WORD1'S should be same as (SUB1 (LSH 1 (SUB1 BITSPERWORD)))") (FRPTQ N (SETQ HI (LLSH (LOGAND HI
 MASK0WORD1\'S) 1)) (SETQ LO (LLSH (|if| (IGEQ LO MASK1WORD0\'S) |then| (|add| HI 1) (LOGAND LO 
MASK0WORD1\'S) |else| LO) 1)))))
(PUTPROPS .XLLSH1. MACRO ((HI LO) (SETQ HI (LLSH (LOGAND HI MASK0WORD1\'S) 1)) (SETQ LO (LSH (COND ((
IGEQ LO MASK1WORD0\'S) (SETQ HI (LOGOR HI 1)) (LOGAND LO MASK0WORD1\'S)) (T LO)) 1))))
(PUTPROPS .XLRSH. MACRO ((HI LO N) (|if| (IGEQ N BITSPERWORD) |then| (* \; 
"Jump 10 bits in a single bound!") (SETQ LO HI) (SETQ HI 0) (SETQ N (IDIFFERENCE N BITSPERWORD))) (
|if| (IGEQ N BITSPERHALFWORD) |then| (* \; "Jump 8 bits in a single bound!") (SETQ LO (LOGOR (
.HIHALFWORDLO. LO) (.LOHALFWORDHI. HI))) (SETQ HI (.HIHALFWORDLO. HI)) (SETQ N (IDIFFERENCE N 
BITSPERHALFWORD))) (|if| (IGEQ N 4) |then| (* \; "Jump 4 bits in a single bound!") (SETQ LO (LOGOR (
LLSH (LOGAND HI (CONSTANT (MASK.1\'S 0 4))) (CONSTANT (IDIFFERENCE BITSPERWORD 4))) (LRSH LO 4))) (
SETQ HI (LRSH HI 4)) (SETQ N (IDIFFERENCE N 4))) (* \; "MASK1WORD0'S should be same as \\SIGNBIT") (
FRPTQ N (SETQ LO (|if| (ODDP HI) |then| (LOGOR (LRSH LO 1) MASK1WORD0\'S) |else| (LRSH LO 1))) (SETQ 
HI (LRSH HI 1)))))
(PUTPROPS .ADD.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* \; "Ignores carry out of high-order word") (
SETQ HX (.SUMSMALLMOD. HX HY)) (SETQ LX (.SUMSMALLMOD. LX LY (SETQ HX (|if| (EQ HX MAX.SMALL.INTEGER) 
|then| 0 |else| (ADD1 HX)))))))
(PUTPROPS .SUB.2WORD.INTEGERS. MACRO ((HX LX HY LY) (* \; "Ignores carry out of high-order word") (
SETQ HX (.DIFFERENCESMALLMOD. HX HY)) (SETQ LX (.DIFFERENCESMALLMOD. LX LY (SETQ HX (|if| (EQ HX 0) 
|then| MAX.SMALL.INTEGER |else| (SUB1 HX)))))))
(PUTPROPS .32BITMUL. MACRO ((HR LR X Y) (PROG (HX LX HY LY) (|if| (ILESSP X Y) |then| (|swap| X Y)) (*
 \; "Y is the lesser of the two now") (.XUNBOX. X HX LX) (.XUNBOX. Y HY LY) LP (|if| (ODDP LY) |then| 
(.ADD.2WORD.INTEGERS. HR LR HX LX)) (|if| (EQ HY 0) |then| (SETQ LY (LRSH LY 1)) (|if| (EQ LY 0) 
|then| (RETURN)) |else| (.LRSH1. HY LY)) (* \; 
"Trim off highest bits, so that left-shifting doesn't generate FIXPs") (SETQ HX (LOGAND HX 
MASK0WORD1\'S)) (.LLSH1. HX LX) (GO LP))))
(PUTPROPS .SUMSMALLMOD. MACRO ((X Y OVERFLOWFORM) ((LAMBDA (|\\SumSmallModVar|) (DECLARE (LOCALVARS 
|\\SumSmallModVar|)) (IF (ILEQ X |\\SumSmallModVar|) THEN (IPLUS X Y) ELSE OVERFLOWFORM (IDIFFERENCE X
 (ADD1 |\\SumSmallModVar|)))) (IDIFFERENCE MAX.SMALL.INTEGER Y))))
(PUTPROPS .DIFFERENCESMALLMOD. MACRO ((X Y BORROWFORM) (IF (NOT (IGREATERP Y X)) THEN (IDIFFERENCE X Y
) ELSE BORROWFORM (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (IDIFFERENCE Y X))))))
(PUTPROPS \\GETBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (|\\Byte|) (DECLARE (LOCALVARS 
|\\Byte|)) (|if| (ODDP OFFST) |then| (LOGAND |\\Byte| (CONSTANT (MASK.1\'S 0 BITSPERNIBBLE))) |else| (
LRSH |\\Byte| BITSPERNIBBLE))) (\\GETBASEBYTE BASE (FOLDLO OFFST NIBBLESPERBYTE)))))
(PUTPROPS \\PUTBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (|\\ByteNo|) (DECLARE (
LOCALVARS |\\ByteNo|)) ((LAMBDA (|\\Byte|) (DECLARE (LOCALVARS |\\Byte|)) (\\PUTBASEBYTE BASE 
|\\ByteNo| (|if| (ODDP OFFST) |then| (LOGOR (LOGAND |\\Byte| (CONSTANT (MASK.1\'S BITSPERNIBBLE 
BITSPERNIBBLE))) VAL) |else| (LOGOR (LOGAND |\\Byte| (CONSTANT (MASK.1\'S 0 BITSPERNIBBLE))) (LLSH VAL
 BITSPERNIBBLE))))) (\\GETBASEBYTE BASE |\\ByteNo|))) (FOLDLO OFFST NIBBLESPERBYTE))))
(PUTPROPS \\GETBASEBIT DMACRO (OPENLAMBDA (BASE OFFST) ((LAMBDA (|\\ByteNo| |\\BitMask|) (DECLARE (
LOCALVARS |\\ByteNo| |\\BitMask|)) (|if| (EQ 0 (LOGAND |\\BitMask| (\\GETBASEBYTE BASE |\\ByteNo|))) 
|then| 0 |else| 1)) (FOLDLO OFFST BITSPERBYTE) (MASK.1\'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) (
IMOD OFFST BITSPERBYTE)) 1))))
(PUTPROPS \\PUTBASEBIT DMACRO (OPENLAMBDA (BASE OFFST VAL) ((LAMBDA (|\\ByteNo| |\\BitMask| |\\Byte|) 
(DECLARE (LOCALVARS |\\ByteNo| |\\BitMask| |\\Byte|)) (SETQ |\\Byte| (\\GETBASEBYTE BASE |\\ByteNo|)) 
(|if| (|if| (EQ 0 (LOGAND |\\BitMask| |\\Byte|)) |then| (NOT (EQ 0 VAL)) |else| (EQ 0 VAL)) |then| (
\\PUTBASEBYTE BASE |\\ByteNo| (LOGXOR |\\BitMask| |\\Byte|))) VAL) (FOLDLO OFFST BITSPERBYTE) (
MASK.1\'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE)) (IMOD OFFST BITSPERBYTE)) 1))))
(PUTPROP (QUOTE ADDARITH) (QUOTE IMPORTDATE) (IDATE "16-May-1990 11:46:37"))

(RPAQQ \\MAXFILEPAGE 65534)
(CONSTANTS \\MAXFILEPAGE)
(PUTPROP (QUOTE LLFAULT) (QUOTE IMPORTDATE) (IDATE "10-Feb-2021 22:44:43"))

(PUTPROPS \\UPDATETIMERS MACRO (NIL (* * |Moves| |excess| |time| |from| |the| |processor| |clock| |to|
 |our| |software| |clocks.| |Needs| |to| |be| |run| |often,| |uninterruptably,| |preferably| |from| 
|the| |vertical| |retrace| |interrupt|) (* |Get| |processor| |clock|) (PROG ((EXCESS (\\BOXIDIFFERENCE
 (\\RCLK (LOCF (|fetch| RCLKTEMP0 |of| \\MISCSTATS))) (LOCF (|fetch| BASECLOCK |of| \\MISCSTATS))))) (
RETURN (COND ((OR (IGEQ EXCESS \\RCLKSECOND) (ILESSP EXCESS 0)) (* |More| |than| |one| |second| |has| 
|elapsed| |since| |we| |updated| |clocks|) (\\BOXIPLUS (LOCF (|fetch| BASECLOCK |of| \\MISCSTATS)) 
\\RCLKSECOND) (* |Increment| |base| |by| |one| |second|) (\\BOXIPLUS (LOCF (|fetch| MILLISECONDSCLOCK 
|of| \\MISCSTATS)) 1000) (* |Increment| |clocks| |by| 1 |second|) (\\BOXIPLUS (LOCF (|fetch| 
SECONDSCLOCK |of| \\MISCSTATS)) 1) T))))))
(RPAQQ \\RTCSECONDS 378)
(RPAQQ \\RTCMILLISECONDS 380)
(RPAQQ \\RTCBASE 382)
(RPAQQ \\OFFSET.SECONDS 0)
(RPAQQ \\OFFSET.MILLISECONDS 2)
(RPAQQ \\OFFSET.BASE 4)
(RPAQQ \\ALTO.RCLKSECOND 1680000)
(RPAQQ \\ALTO.RCLKMILLISECOND 1680)
(RPAQQ \\DLION.RCLKMILLISECOND 35)
(RPAQQ \\DLION.RCLKSECOND 34746)
(RPAQQ \\DOVE.RCLKMILLISECOND 63)
(RPAQQ \\DOVE.RCLKSECOND 62500)
(CONSTANTS (\\RTCSECONDS 378) (\\RTCMILLISECONDS 380) (\\RTCBASE 382) (\\OFFSET.SECONDS 0) (
\\OFFSET.MILLISECONDS 2) (\\OFFSET.BASE 4) (\\ALTO.RCLKSECOND 1680000) (\\ALTO.RCLKMILLISECOND 1680) (
\\DLION.RCLKMILLISECOND 35) (\\DLION.RCLKSECOND 34746) (\\DOVE.RCLKMILLISECOND 63) (\\DOVE.RCLKSECOND 
62500))
(PUTPROPS ALTO.TO.LISP.DATE MACRO ((DATE) (LOGXOR DATE -2147483648)))
(PUTPROPS LISP.TO.ALTO.DATE MACRO ((DATE) (LOGXOR DATE -2147483648)))
(PUTPROP (QUOTE LLTIMER) (QUOTE IMPORTDATE) (IDATE "16-May-1990 20:13:11"))

(DATATYPE SYSQUEUE ((NIL BYTE) (SYSQUEUEHEAD POINTER) (NIL BYTE) (SYSQUEUETAIL POINTER)))
(BLOCKRECORD QABLEITEM ((NIL BITS 4) (QLINK POINTER) (* \; 
"Link to next thing in queue always in first pointer of datum, independent of what the datum is")) (
BLOCKRECORD QABLEITEM ((NIL BITS 4) (LINK POINTER) (* \; "Let's also be able to call it a LINK"))))
(PUTPROPS \\QUEUEHEAD MACRO ((Q) (|fetch| (SYSQUEUE SYSQUEUEHEAD) |of| Q)))
(PUTPROPS \\DETCONC MACRO (OPENLAMBDA (TQ) (PROG1 (\\PEEKTCONC TQ) (|if| (NULL (CAR (RPLACA TQ (CDAR 
TQ)))) |then| (RPLACD TQ)))))
(PUTPROPS \\ENTCONC MACRO (= . TCONC))
(PUTPROPS \\PEEKTCONC MACRO (= . CAAR))
(DATATYPE ETHERPACKET ((NIL BYTE) (EPLINK POINTER) (* \; "For queue maintenence") (EPFLAGS BYTE) (* \;
 "optional flags for some applications") (EPUSERFIELD POINTER) (* \; 
"Arbitrary pointer for applications") (NIL BYTE) (EPPLIST POINTER) (* \; 
"Extra field for use as an A-list for properties") (EPTRANSMITTING FLAG) (* \; 
"True while packet is being transmitted and hence cannot be reused") (EPRECEIVING FLAG) (* \; 
"True when a packet has been seen at the head of the network's input queue at least once") (NIL BITS 6
) (EPREQUEUE POINTER) (* \; "Where to requeue this packet after transmission") (NIL BYTE) (EPSOCKET 
POINTER) (NIL BYTE) (EPNETWORK POINTER) (EPTYPE WORD) (* \; 
"Type of packet to be encapsulated (PUP or XIP or 10TO3)") (NIL WORD) (EPTIMESTAMP FIXP) (* \; 
"Gets RCLK value when transmitted/received") (EPREQUEUEFN POINTER) (* \; "FN to perform requeueing") (
NIL 4 WORD) (* \; "Space for expansion") (* \; 
"Note: This next field wants to be quad+2 aligned so that the 10mb packet is quad+3 aligned") (
EPENCAPSULATION 8 WORD) (* \; "10mb encapsulation, or 3mb encapsulation with padding") (EPBODY 289 
WORD) (* \; "Body of packet, header up to 16 words plus data up to 546 bytes")))
(ACCESSFNS ETHERAUX ((AUXPTR (CDR (ASSOC (QUOTE AUXPTR) (|fetch| EPPLIST |of| DATUM))) (\\EP.PUT.AUX 
DATUM (QUOTE AUXPTR) NEWVALUE)) (AUXWORD (OR (CDR (ASSOC (QUOTE AUXWORD) (|fetch| EPPLIST |of| DATUM))
) 0) (\\EP.PUT.AUX DATUM (QUOTE AUXWORD) NEWVALUE)) (AUXBYTE (OR (CDR (ASSOC (QUOTE AUXBYTE) (|fetch| 
EPPLIST |of| DATUM))) 0) (\\EP.PUT.AUX DATUM (QUOTE AUXBYTE) NEWVALUE))))
(RPAQQ \\EPT.PUP 512)
(RPAQQ \\EPT.XIP 1536)
(RPAQQ \\3MBTYPE.XIP 1536)
(RPAQQ \\10MBTYPE.XIP 1536)
(RPAQQ \\EPT.10TO3 1537)
(RPAQQ \\3MBTYPE.10TO3 1537)
(RPAQQ \\EPT.UNKNOWN 255)
(CONSTANTS \\EPT.PUP \\EPT.XIP \\3MBTYPE.XIP \\10MBTYPE.XIP \\EPT.10TO3 \\3MBTYPE.10TO3 \\EPT.UNKNOWN)
(RPAQQ \\NULLCHECKSUM 65535)
(CONSTANTS (\\NULLCHECKSUM 65535))
(DATATYPE NDB ((NETTYPE BYTE) (* \; "10 or 3 for now") (NDBNEXT POINTER) (* \; "Link to next NDB") (
NDBPUPNET# BYTE) (* \; 
"Pup number of this net.  May be different from NS net number, though not in Xerox world") (NDBNSNET# 
POINTER) (* \; "Can be 32-bits, so might as well leave its box around") (NDBTASK# BYTE) (* \; 
"Task # of this network") (NDBBROADCASTP POINTER) (* \; 
"Function that returns true if packet is of broadcast type") (NDBPUPHOST# BYTE) (* \; 
"My pup address on this net.  NS address is global to all nets, so not needed here") (NDBTRANSMITTER 
POINTER) (* \; "(NDB PACKET) -- fn to send a raw packet on this net.  returns NIL on failure") (NIL 
BYTE) (NDBENCAPSULATOR POINTER) (* \; 
"(NDB PACKET HOST LENGTH TYPE) -- fn to encapsulate and send a higher-level packet on this net ") (
NDBCSB POINTER) (* \; "Pointer to CSB for this network") (NDBIQLENGTH BYTE) (NDBIQ POINTER) (* \; 
"Queue of empty packets for receiver") (NDBTQ POINTER) (* \; "Queue of packets to transmit") (
NDBTRANSLATIONS POINTER) (* \; "Cache of translations, 3:10 or 10:3 according to network") (
NDBETHERFLUSHER POINTER) (* \; "Turns off this ether.  Args NDB") (NDBWATCHER POINTER) (NDBCANHEARSELF
 POINTER) (* \; "True if receiver can hear packets sent by transmitter") (NDBIPNET# POINTER) (
NDBIPHOST# POINTER) (NDBPUPTYPE WORD) (* \; "The packet encapsulation of PUP on this net") (NIL WORD) 
(NIL POINTER) (* \; "Spares")))
(RECORD ROUTING (RTNET# RTHOPCOUNT RTGATEWAY# RTNDB RTTIMER RTRECENT))
(PUTPROPS \\SERIALNUMBER MACRO (NIL (|fetch| (IFPAGE |SerialNumber|) |of| |\\InterfacePage|)))
(PUTPROPS \\DEVICE.INPUT DOPVAL (1 MISC1 1))
(PUTPROPS \\DEVICE.OUTPUT DOPVAL (2 MISC2 2))
(PUTPROPS \\D0.STARTIO DOPVAL (1 MISC1 0))
(PUTPROP (QUOTE LLETHER) (QUOTE IMPORTDATE) (IDATE "19-Jan-1993 10:49:30"))

(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR) BRUSHSHAPE _ (QUOTE ROUND) BRUSHSIZE _ 1)
(PUTPROPS IMAGEOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) (
QUOTE QUOTE)) (LIST (QUOTE |fetch|) (LIST (QUOTE IMAGEOPS) (CADAR ARGS)) (QUOTE |of|) (LIST (QUOTE 
|fetch|) (QUOTE (STREAM IMAGEOPS)) (QUOTE |of|) (CADR ARGS)))) (T (HELP "IMAGEOP - OPNAME not quoted:"
 ARGS))) (CDDR ARGS)))))
(DATATYPE IMAGEOPS (IMAGETYPE IMCLOSEFN IMXPOSITION IMYPOSITION IMFONT IMLEFTMARGIN IMRIGHTMARGIN 
IMLINEFEED IMDRAWLINE IMDRAWCURVE IMDRAWCIRCLE IMDRAWELLIPSE IMFILLCIRCLE IMBLTSHADE IMBITBLT 
IMNEWPAGE IMMOVETO IMSCALE IMTERPRI IMTOPMARGIN IMBOTTOMMARGIN IMSPACEFACTOR IMFONTCREATE IMOPERATION 
IMCOLOR IMSTRINGWIDTH IMCHARWIDTH IMCHARWIDTHY IMBACKCOLOR IMBITMAPSIZE IMCLIPPINGREGION IMRESET 
IMDRAWPOLYGON IMFILLPOLYGON IMSCALEDBITBLT IMWRITEPIXEL IMCHARSET IMROTATE IMDRAWARC IMTRANSLATE 
IMSCALE2 IMPUSHSTATE IMPOPSTATE IMDEFAULTSTATE IMDRAWPOINT IMBLTCHAR IMXOFFSET IMYOFFSET) IMCLOSEFN _ 
(FUNCTION NILL) IMTERPRI _ (FUNCTION (LAMBDA (STREAM) (\\OUTCHAR STREAM (CHARCODE EOL)))) IMNEWPAGE _ 
(FUNCTION (LAMBDA (STREAM) (\\OUTCHAR STREAM (CHARCODE ^L)))) IMOPERATION _ (FUNCTION NILL) IMCOLOR _ 
(FUNCTION NILL) IMCLIPPINGREGION _ (FUNCTION NILL) IMRESET _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION 
NILL) IMSTRINGWIDTH _ (FUNCTION (LAMBDA (STREAM STR RDTBL) (STRINGWIDTH STR (DSPFONT NIL STREAM) RDTBL
 RDTBL))) IMCHARWIDTH _ (FUNCTION (LAMBDA (STREAM CHARCODE) (CHARWIDTH CHARCODE (DSPFONT NIL STREAM)))
) IMMOVETO _ (FUNCTION (LAMBDA (STREAM X Y) (IMAGEOP (QUOTE IMXPOSITION) STREAM STREAM X) (IMAGEOP (
QUOTE IMYPOSITION) STREAM STREAM Y))) IMBITMAPSIZE _ (FUNCTION (LAMBDA (STREAM BITMAP DIMENSION) (
SELECTQ DIMENSION (WIDTH (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP))) (HEIGHT (TIMES (DSPSCALE 
NIL STREAM) (BITMAPHEIGHT BITMAP))) (NIL (CONS (TIMES (DSPSCALE NIL STREAM) (BITMAPWIDTH BITMAP)) (
TIMES (DSPSCALE NIL STREAM) (BITMAPHEIGHT BITMAP)))) (\\ILLEGAL.ARG DIMENSION)))) IMWRITEPIXEL _ (
FUNCTION NILL) IMCHARSET _ (FUNCTION NILL) IMXPOSITION _ (FUNCTION NILL) IMYPOSITION _ (FUNCTION NILL)
 IMFONT _ (FUNCTION NILL) IMLEFTMARGIN _ (FUNCTION NILL) IMRIGHTMARGIN _ (FUNCTION NILL) IMLINEFEED _ 
(FUNCTION NILL) IMDRAWLINE _ (FUNCTION NILL) IMDRAWCURVE _ (FUNCTION NILL) IMDRAWCIRCLE _ (FUNCTION 
NILL) IMDRAWELLIPSE _ (FUNCTION NILL) IMFILLCIRCLE _ (FUNCTION NILL) IMBLTSHADE _ (FUNCTION NILL) 
IMBITBLT _ (FUNCTION NILL) IMSCALE _ (FUNCTION NILL) IMTOPMARGIN _ (FUNCTION NILL) IMBOTTOMMARGIN _ (
FUNCTION NILL) IMSPACEFACTOR _ (FUNCTION NILL) IMFONTCREATE _ (FUNCTION NILL) IMCHARWIDTHY _ (FUNCTION
 NILL) IMDRAWPOLYGON _ (FUNCTION \\DRAWPOLYGON.GENERIC) IMDRAWPOINT _ (FUNCTION \\DRAWPOINT.GENERIC) 
IMFILLPOLYGON _ (FUNCTION NILL) IMSCALEDBITBLT _ (FUNCTION NILL) IMROTATE _ (FUNCTION NILL) IMDRAWARC 
_ (FUNCTION NILL) IMTRANSLATE _ (FUNCTION NILL) IMPUSHSTATE _ (FUNCTION NILL) IMPOPSTATE _ (FUNCTION 
NILL) IMSCALE2 _ (FUNCTION NILL) IMDEFAULTSTATE _ (FUNCTION NILL) IMBLTCHAR _ (FUNCTION \\MEDW.BLTCHAR
) IMXOFFSET _ (FUNCTION \\MEDW.XOFFSET) IMYOFFSET _ (FUNCTION \\MEDW.YOFFSET))
(GLOBALVARS \\NOIMAGEOPS)
(PUTPROP (QUOTE IMAGEIO) (QUOTE IMPORTDATE) (IDATE "28-Jun-1999 16:33:59"))

(DATATYPE PROCESS ((PROCFX0 WORD) (* \; "= \\STACKHI to make this look like a STACKP") (PROCFX WORD) (
* \; "Stack pointer to this context when it is asleep") (PROCSTATUS BYTE) (* \; "Running or waiting") 
(PROCNAME POINTER) (* \; "Name for convenience in type-in reference") (PROCPRIORITY BYTE) (* \; 
"Priority level, 0-4.  Not currently used.") (PROCQUEUE POINTER) (* \; 
"Queue of processes at the same priority") (NIL BYTE) (NEXTPROCHANDLE POINTER) (* \; 
"Pointer to next one") (PROCTIMERSET FLAG) (* \; "True if PROCWAKEUPTIMER has an interesting value") (
PROCBEINGDELETED FLAG) (* \; "True if proc was deleted, but hasn't been removed from \\PROCESSES yet")
 (PROCDELETED FLAG) (PROCSYSTEMP FLAG) (PROCNEVERSTARTED FLAG) (NIL FLAG) (NIL FLAG) (NIL FLAG) (
PROCWAKEUPTIMER POINTER) (* \; "a largep recording the time this proc last went to sleep") (
PROCTIMERLINK POINTER) (* \; "For linking proc in timer queue") (PROCTIMERBOX POINTER) (* \; 
"Scratch box to use for PROCWAKEUPTIMER when user does not give one explicitly") (WAKEREASON POINTER) 
(* \; "Reason process is being run.  From WAKE.PROCESS or timer or event wakeup;  T from simple BLOCK"
) (PROCEVENTORLOCK POINTER) (* \; "EVENT or MONITOR lock that this proc is waiting for") (PROCFORM 
POINTER) (* \; "Form to EVAL to start it going") (RESTARTABLE POINTER) (* \; 
"T = autorestart on error, HARDRESET = restart only on hard reset, NIL = never restart") (PROCWINDOW 
POINTER) (* \; "Window this process lives in, if any") (PROCFINISHED POINTER) (* \; 
"True if proc finished.  Value is indication of how: NORMAL, DELETED, ERROR") (PROCRESULT POINTER) (* 
\; "Value it returned if it finished normally") (PROCFINISHEVENT POINTER) (* \; 
"Optional EVENT to be notified when proc finishes") (PROCMAILBOX POINTER) (* \; "Message queue") (
PROCDRIBBLEOUTPUT POINTER) (* \; "Binding for *DRIBBLE-OUTPUT* in this process") (PROCINFOHOOK POINTER
) (* \; "Optional user fn that displays info about process") (PROCTYPEAHEAD POINTER) (* \; 
"Buffer of typeahead destined for this proc") (PROCREMOTEINFO POINTER) (* \; "For Enterprise") (
PROCUSERDATA POINTER) (* \; "For PROCESSPROP") (PROCEVENTLINK POINTER) (* \; 
"Used to maintain EVENT queues") (PROCAFTEREXIT POINTER) (* \; 
"What to do with this process when coming back from a LOGOUT, etc") (PROCBEFOREEXIT POINTER) (* \; 
"If DON'T, can't logout") (PROCOWNEDLOCKS POINTER) (* \; "Pointer to first lock I currently own") (
PROCEVAPPLYRESULT POINTER) (* \; "For PROCESS.EVAL and PROCESS.APPLY when WAITFORRESULT is true") (
PROCTTYENTRYFN POINTER) (* \; "Is applied to a process when it becomes the tty process") (
PROCTTYEXITFN POINTER) (* \; "Is applied to a process when it ceases to be the tty process") (
PROCHARDRESETINFO POINTER) (* \; "HARDRESET stores info about unwind-protect cleanups here") (
PROCRESTARTFORM POINTER) (* \; "use this instead of PROCFORM when restarting") (PROCOLDTTYPROC POINTER
) (* \; "Process that had the tty when we got it") (NIL POINTER) (* \; "For expansion")) PROCTIMERBOX 
_ (CREATECELL \\FIXP) PROCFX0 _ \\STACKHI)
(PUTPROPS THIS.PROCESS MACRO (NIL \\RUNNING.PROCESS))
(PUTPROPS TTY.PROCESS MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE \\TTY.PROCESS)))))
(PUTPROPS TTY.PROCESSP MACRO (X (COND ((CAR X) (QUOTE IGNOREMACRO)) (T (QUOTE (OR (NULL (THIS.PROCESS)
) (EQ (THIS.PROCESS) (TTY.PROCESS))))))))
(GLOBALVARS \\RUNNING.PROCESS \\TTY.PROCESS \\PROC.RESTARTME \\PROC.RESETME \\PROC.ABORTME)
(PUTPROP (QUOTE PROC) (QUOTE IMPORTDATE) (IDATE "17-Jun-1999 21:58:52"))

(PUTPROPS \\BACKCHAR MACRO (OPENLAMBDA (STREAM) (* \; "Backs up over an NS character") (\\BACKNSCHAR 
STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256))))
(PUTPROPS \\BACKNSCHAR MACRO ((ST SHIFTEDCHARSET COUNTERVAR) (COND ((\\XCCSP ST) (\\BACKXCCSCHAR ST 
SHIFTEDCHARSET COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR (
CL:FUNCALL (|ffetch| (STREAM BACKCHARFN) |of| ST) ST T)))) (T (CL:FUNCALL (|ffetch| (STREAM BACKCHARFN
) |of| ST) ST NIL)))))))
(PUTPROPS \\CHECKEOLC MACRO (OPENLAMBDA (CH EOLC STREAM PEEKBINFLG COUNTERVAR) (* |;;| 
"Subtracts number of bytes read from COUNTERVAR, which may be NIL.  In fact, should be NIL if PEEKBINFLG is T."
) (SELCHARQ CH (CR (SELECTC EOLC (CR.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND (PEEKBINFLG (* |;;| 
"T from PEEKC, compile-time constant.  In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts"
) (COND ((EQ (CHARCODE LF) (UNINTERRUPTABLY (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* 
|;;| 
"Read the NS CR.  We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \\NSPEEK that got the CR character.  Since we are going to NS back the CR character, we don't need to update the counter variable"
) (PROG1 (\\PEEKBIN STREAM T) (* |;;| 
"LF must be in next BYTE after NS CR, regardless of coding.  Character-set shifting bytes can't intervene.  Then we back up over the CR that was \\NSINed above."
) (\\BACKNSCHAR STREAM)))) (CHARCODE EOL)) (T (CHARCODE CR)))) ((EQ (CHARCODE LF) (\\PEEKBIN STREAM T)
) (\\BIN STREAM) (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (SUB1 COUNTERVAR))) (CHARCODE EOL)) (T (
CHARCODE CR)))) (CHARCODE CR))) (LF (COND ((EQ EOLC LF.EOLC) (CHARCODE EOL)) (T (CHARCODE LF)))) CH)))
(PUTPROPS \\INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* \; "returns a 16 bit character code") (
\\CHECKEOLC (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (FFETCH EOLCONVENTION 
OF STREAM) STREAM NIL COUNTERVAR)))
(PUTPROPS \\INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* \; "returns a 16 bit character code") (
\\CHECKEOLC (\\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (|ffetch| 
EOLCONVENTION |of| STREAM) STREAM NIL COUNTERVAR)))
(PUTPROPS \\PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR) (\\CHECKEOLC (\\NSPEEK STREAM (UNFOLD (
ACCESS-CHARSET STREAM) 256) NIL NOERROR) (|ffetch| EOLCONVENTION |of| STREAM) STREAM T)))
(PUTPROPS \\NSIN MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* |;;;| 
"Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here."
) (COND ((\\XCCSP ST) (\\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)) (T (COND ((QUOTE COUNTERVAR
) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (|ffetch| (STREAM INCCODEFN) |of| ST) ST T) (AND NUM 
(SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (|ffetch| (STREAM INCCODEFN) 
|of| ST) ST NIL)))))))
(PUTPROPS \\NSPEEK MACRO ((ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* |;;;| 
"Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here."
) (COND ((\\XCCSP ST) (\\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST) 256) NIL NOERROR)) (T (COND ((QUOTE 
COUNTERVAR) (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (|ffetch| (STREAM PEEKCCODEFN) |of| ST) ST 
NOERROR T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (|ffetch| (
STREAM PEEKCCODEFN) |of| ST) ST NOERROR NIL)))))))
(PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET))
(PUTPROPS \\CONV.JIS.TO.XCCS MACRO (OPENLAMBDA (KU TEN) (* |;;;| 
"Some character code is not equivalent between JIS and XCCS.  In such case, we have to convert the character to corresponding XCCS."
) (COND ((\\NOT.EQUIVALENT.TO.XCCS KU) (\\DO.CONV.JIS.TO.XCCS KU TEN)) (T (LOGOR (UNFOLD KU 256) TEN))
)))
(PUTPROPS \\DO.CONV.JIS.TO.XCCS MACRO ((KU TEN) (* |;;;| 
" Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.")
 (COND ((\\INVALID.TENP TEN) *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (SELECTQ KU ((33 34 38) (* \; 
"1, 2 and 6 KU") (LET* ((CONVTABLE (\\EXTARACT.CONV.TABLE KU)) (SET (\\EXTRACT.SET TEN CONVTABLE)) (
CODE (\\EXTRACT.CODE TEN CONVTABLE))) (COND ((NEQ SET 255) (LOGOR (UNFOLD SET 256) CODE)) (T (COND ((
EQ CODE 255) (* \; "Not defined in JIS.") *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (* \; 
"Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.") (COND (
*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 
256) TEN)))))))))) (35 (* \; "3 KU") (* \; 
"Alpha numeric codes are all defined as single byte codes in XCCS.") TEN) (40 (* \; "8 KU") (COND ((< 
0 TEN 33) (COND (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\\EXTRACT.NO.FONT.CODE (
LOGOR KU TEN))))) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (116 (* \; "84 KU") (COND ((< 0 TEN 5) (LOGOR
 29952 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (117 (* \; "85 KU") (COND ((< 0 TEN 28) (LOGOR 
29696 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) *DEFAULT-NOT-CONVERTED-FAT-CODE*)))))
(PUTPROPS \\CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC) (* |;;;| 
"Returns JIS code corresponding to XCCS charcode.  Handle HANKAKU as well as ZENKAKU.  If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so.  Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode."
) (OR (COND ((\\ASCIIP CC) CC) ((\\NOT.EQUIVALENT.TO.JIS CC) (\\DO.CONV.XCCS.TO.JIS CC)) ((
\\CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM) (* \; 
"ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.") (\\CONV.ZENKAKU.KANA CC)) (
T CC)) CC)))
(PUTPROPS \\DO.CONV.XCCS.TO.JIS MACRO ((CC) (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*)))
(PUTPROPS \\ASCIIP MACRO (OPENLAMBDA (CC) (AND (EQ (FOLDLO CC 256) 0) (< (LOGAND CC 255) 128))))
(PUTPROPS \\NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC) (OR (EQ (FOLDLO CC 256) 0) (EQ (FOLDLO CC 256
) 33) (EQ (FOLDLO CC 256) 34) (EQ (FOLDLO CC 256) 38) (EQ (FOLDLO CC 256) 40) (EQ (FOLDLO CC 256) 239)
 (EQ (FOLDLO CC 256) 241))))
(PUTPROPS \\CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM) (STREAMPROP OUTSTREAM :HTOZP)))
(PUTPROPS \\CONV.ZENKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*)))
(PUTPROPS \\XCCSIN MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* |;;;| 
"returns a 16 bit character code.  SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes.  COUNTERVAR if non-NIL is decremented by number of bytes read.  Doesn't do EOL conversion -- \\INCHAR and \\INCCODE do that."
) (LET ((CHAR (\\BIN STREAM)) SCSET) (COND ((EQ CHAR NSCHARSETSHIFT) (* \; "Shifting character sets") 
(ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\\BIN STREAM))) (AND (QUOTE 
COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* \; 
"2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE 
COUNTERVAR 3))) (EQ 0 (\\BIN STREAM))) \\NORUNCODE) (T (\\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ 
CHAR (\\BIN STREAM)) (SETQ SCSET (COND ((QUOTE SHIFTEDCSETVAR) (* \; "CHARSETVAR=NIL means don't set")
 (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256))))) (T (SETQ SCSET SHIFTEDCSET))) (
COND ((EQ SCSET (UNFOLD \\NORUNCODE 256)) (* \; 
"just read two bytes and combine them to a 16 bit value") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (
IDIFFERENCE COUNTERVAR 2))) (LOGOR (UNFOLD CHAR 256) (\\BIN STREAM))) (CHAR (AND (QUOTE COUNTERVAR) (
SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 1))) (AND CHAR (LOGOR SCSET CHAR)))))))
(PUTPROPS \\XCCSPEEK MACRO ((STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* |;;| 
"Returns a 16 bit character code.  Doesn't do EOL conversion--\\INCHAR does that.  May actually read the character-set shift, storing the result in the stream.  COUNTERVAR, if given, is updated to reflect any such bytes that are actually read"
) (PROG ((CHAR (\\PEEKBIN STREAM NOERROR)) SCSET) (COND ((NULL CHAR) (RETURN NIL)) ((EQ CHAR 
NSCHARSETSHIFT) (* \; "CHARSETVAR=NIL means don't set") (\\BIN STREAM) (* \; 
"Consume the char shift byte") (ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ 
CHAR (\\BIN STREAM))) (* \; 
"Note: no eof error check on this \\BIN -- an eof in the middle of a charset shift is an error") (AND 
(QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* \; 
"2 shift-bytes means not run-encoded") (AND (QUOTE COUNTERVAR) (SETQ COUNTERVAR (IDIFFERENCE 
COUNTERVAR 3))) (EQ 0 (\\BIN STREAM))) \\NORUNCODE) (T (\\NSIN.24BITENCODING.ERROR STREAM))))) (SETQ 
SCSET (COND ((QUOTE SHIFTEDCSETVAR) (* \; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (
UNFOLD SCSET 256))) (T (UNFOLD SCSET 256)))) (COND ((NULL (SETQ CHAR (\\PEEKBIN STREAM NOERROR))) (
RETURN NIL)))) (T (SETQ SCSET SHIFTEDCSET))) (RETURN (COND ((EQ SCSET (UNFOLD \\NORUNCODE 256)) (* 
|;;| 
"just peek two bytes and combine them to a 16 bit value.  Again, is an error if we hit eof in mid-character"
) (\\BIN STREAM) (PROG1 (LOGOR (UNFOLD CHAR 256) (\\PEEKBIN STREAM NOERROR)) (\\BACKFILEPTR STREAM))) 
(T (LOGOR SHIFTEDCSET CHAR)))))))
(PUTPROPS \\BACKXCCSCHAR MACRO ((STREAM SHIFTEDCHARSET COUNTERVAR) (AND (\\BACKFILEPTR STREAM) (COND (
(COND (SHIFTEDCHARSET (EQ SHIFTEDCHARSET (UNFOLD \\NORUNCODE 256))) (T (EQ \\NORUNCODE (ACCESS-CHARSET
 STREAM)))) (COND ((\\BACKFILEPTR STREAM) (AND (QUOTE COUNTERVAR) (|add| COUNTERVAR 2)) T) ((QUOTE 
COUNTERVAR) (|add| COUNTERVAR 1)))) ((QUOTE COUNTERVAR) (|add| COUNTERVAR 1))))))
(PUTPROPS \\XCCSP MACRO (OPENLAMBDA (ST) (NOT (|ffetch| (STREAM NOTXCCS) |of| (\\DTEST ST (QUOTE 
STREAM))))))
(PUTPROPS \\EXTRACT.NO.FONT.CODE MACRO ((JISCODE) (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE*
))))
(PUTPROPS \\EXTARACT.CONV.TABLE MACRO ((KU) (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*))))
(PUTPROPS \\NOT.EQUIVALENT.TO.XCCS MACRO ((KU) (* |;;;| 
" The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU.  Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here."
) (OR (EQ KU 33) (EQ KU 34) (EQ KU 35) (EQ KU 38) (EQ KU 40) (EQ KU 116) (EQ KU 117))))
(PUTPROPS \\EXTRACT.SET MACRO ((TEN TABLE) (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32) 2) 1))
))
(PUTPROPS \\EXTRACT.CODE MACRO ((TEN TABLE) (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32) 2))))
(PUTPROPS \\CHNAGE.KI.MODE MACRO (OPENLAMBDA (ST INPUTFLG ENTERP) (* |;;;| 
"INPUTFLG is true if \\CHNAGE.KI.MODE is called in the context in which ST is an input stream.") (COND
 (INPUTFLG (COND (ENTERP (|freplace| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| T)) (
T (|freplace| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| NIL)))) (T (COND (ENTERP (
|freplace| (STREAM OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| T)) (T (|freplace| (STREAM 
OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)) |with| NIL)))))))
(PUTPROPS \\KIMODEP MACRO (OPENLAMBDA (ST INPUTFLG) (* |;;;| 
"INPUTFLG is true if \\KIMODEP is called in the context in which ST is an input stream.") (COND (
INPUTFLG (|ffetch| (STREAM IN.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)))) (T (|ffetch| (STREAM 
OUT.KANJIIN) |of| (\\DTEST ST (QUOTE STREAM)))))))
(PUTPROPS \\HANKAKUP MACRO ((CHAR) (< 160 CHAR 224)))
(PUTPROPS \\KANJIP MACRO ((CHAR) (< 12158 CHAR 29733)))
(PUTPROPS \\NOTGAIJIP MACRO ((CHAR) (OR (< 8480 CHAR 10305) (< 12158 CHAR 29733))))
(PUTPROPS \\INVALID.TENP MACRO (OPENLAMBDA (TEN) (OR (< TEN 33) (< 126 TEN))))
(PUTPROPS \\CONV.HANKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*)))
(PUTPROPS \\OUTKI MACRO ((STREAM) (\\BOUT OUTSTREAM (CHARCODE ESC)) (\\BOUT OUTSTREAM (CHARCODE $)) (
\\BOUT OUTSTREAM (CHARCODE B))))
(PUTPROPS \\OUTKO MACRO ((STREAM) (\\BOUT OUTSTREAM (CHARCODE ESC)) (\\BOUT OUTSTREAM (CHARCODE \()) (
\\BOUT OUTSTREAM (CHARCODE J))))
(PUTPROPS \\CONV.SJIS.TO.JIS MACRO (OPENLAMBDA (HI LO) (* |;;;| 
"Convert Shift-JIS to JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively."
) (SETQ CH1 (IDIFFERENCE HI (COND ((> HI 159) 177) (T 113)))) (SETQ CH1 (IPLUS (UNFOLD CH1 2) 1)) (
SETQ CH2 (COND ((> LO 158) (PROG1 (IDIFFERENCE LO 126) (SETQ CH1 (IPLUS CH1 1)))) (T (IDIFFERENCE LO (
COND ((> LO 126) (IPLUS 31 1)) (T 31))))))))
(PUTPROPS \\CONV.JIS.TO.SJIS MACRO (OPENLAMBDA (HI LO) (* |;;;| 
"Convert JIS to Shift-JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively."
) (SETQ CH2 (COND ((ODDP HI) (SETQ CH2 (IPLUS LO 31)) (COND ((>= CH2 127) (IPLUS CH2 1)) (T CH2))) (T 
(IPLUS LO 126)))) (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33) 2) 129)) (AND (> CH1 159) (SETQ CH1 (
IPLUS CH1 64)))))
(PUTPROPS \\SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR) (OR (< 127 CHAR 160) (< 223 CHAR 256))))
(PUTPROPS \\EUC.KANJI.FIRST.BYTEP MACRO ((CHAR) (< 160 CHAR 255)))
(PUTPROPS \\GAIJIP MACRO ((CHAR) (EQ CHAR 143)))
(PUTPROPS \\EUC.HANKAKUP MACRO ((CHAR) (EQ CHAR 142)))
(PUTPROP (QUOTE LLREAD) (QUOTE IMPORTDATE) (IDATE " 4-Feb-2021 17:06:41"))

(PUTPROPS EMPASSWORDLOC DMACRO (LAMBDA NIL (* |lmm| "24-MAR-83 06:46") (|fetch| (IFPAGE |UserPswdAddr|
) |of| |\\InterfacePage|)))
(PUTPROPS \\DECRYPT.PWD.CHAR MACRO ((CHAR) (LOGXOR CHAR 73)))
(PUTPROP (QUOTE PASSWORDS) (QUOTE IMPORTDATE) (IDATE "16-May-1990 21:02:21"))

(RPAQQ MICASPERINCH 2540)
(RPAQQ MICASPERMILLIMETER 100)
(CONSTANTS (MICASPERINCH 2540) (MICASPERMILLIMETER 100))
(PUTPROP (QUOTE INTERPRESS) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 21:56:38"))

(RPAQ MICASPERPT (FQUOTIENT 2540 72))
(RPAQQ IHALFMICASPERPT 17)
(RPAQQ IMICASPERPT 35)
(CONSTANTS (MICASPERPT (FQUOTIENT 2540 72)) (IHALFMICASPERPT 17) (IMICASPERPT 35))
(DEFMACRO \\MICASTOPTS (MICAS) (COND ((NUMBERP MICAS) (QUOTIENT MICAS MICASPERPT)) (T (BQUOTE (
QUOTIENT (\\\, MICAS) MICASPERPT)))))
(PUTPROP (QUOTE HARDCOPY) (QUOTE IMPORTDATE) (IDATE "16-Apr-2018 22:15:08"))

(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT)
(PUTPROP (QUOTE CMLARRAY) (QUOTE IMPORTDATE) (IDATE " 6-Jan-1993 12:21:21"))

(RPAQQ \\MISCN-TABLE-LIST ((USER-SUBR 0 \\USER-SUBR-UFN T) (CL:VALUES 1 CL::VALUES-UFN NIL) (CL:SXHASH
 2 CL::SXHASH-UFN NIL) (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL) (STRINGHASHBITS 4 
\\STRINGHASHBITS-UFN NIL) (STRING-EQUAL-HASHBITS 5 \\STRING-EQUAL-HASHBITS-UFN NIL) (CL:VALUES-LIST 6 
CL::VALUES-LIST-UFN NIL) (|LCFetchMethod| 7 |LCFetchMethod| NIL) (|LCFetchMethodOrHelp| 8 NIL NIL) (
|LCFindVarIndex| 9 NIL NIL) (|LCGetIVValue| 10 NIL NIL) (|LCPutIVValue| 11 NIL NIL)))
(RPAQQ \\USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN) (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))
(RPAQQ \\INITSUBRS ((BACKGROUNDSUBR 6) (CHECKBCPLPASSWORD 7) (DISKPARTITION 8) (DSPBOUT 9) (DSPRATE 10
) (GATHERSTATS 11) (GETPACKETBUFFER 12) (LISPFINISH 13) (MOREVMEMFILE 14) (RAID 15) (READRAWPBI 16) (
WRITERAWPBI 17) (SETSCREENCOLOR 18) (SHOWDISPLAY 19) (PUPLEVEL1STATE 20) (WRITESTATS 21) (
CONTEXTSWITCH 22) (COPYSYS0SUBR 23) (WRITEMAP 24) (UFS-GETFILENAME 34) (UFS-DELETEFILE 35) (
UFS-RENAMEFILE 36) (COM-READPAGES 37) (COM-WRITEPAGES 38) (COM-TRUNCATEFILE 39) (UFS-DIRECTORYNAMEP 41
) (COM-GETFREEBLOCK 45) (SETUNIXTIME 48) (GETUNIXTIME 49) (COPYTIMESTATS 50) (UNIX-USERNAME 51) (
UNIX-FULLNAME 52) (UNIX-GETENV 53) (UNIX-GETPARM 54) (CHECK-SUM 55) (ETHER-SUSPEND 56) (ETHER-RESUME 
57) (ETHER-AVAILABLE 58) (ETHER-RESET 59) (ETHER-GET 60) (ETHER-SEND 61) (ETHER-SETFILTER 62) (
ETHER-CHECK 63) (DSPCURSOR 64) (SETMOUSEXY 65) (DSP-VIDEOCOLOR 66) (DSP-SCREENWIDTH 67) (
DSP-SCREENHEIGHT 68) (BITBLTSUB 69) (BLTCHAR 70) (TEDIT.BLTCHAR 71) (BITBLT.BITMAP 72) (
BLTSHADE.BITMAP 73) (RS232C-CMD 74) (RS232C-READ-INIT 75) (RS232C-WRITE 76) (KEYBOARDBEEP 80) (
KEYBOARDMAP 81) (KEYBOARDSTATE 82) (VMEMSAVE 89) (LISP-FINISH 90) (NEWPAGE 91) (DORECLAIM 92) (
DUMMY-135Q 93) (NATIVE-MEMORY-REFERENCE 94) (OLD-COMPILE-LOAD-NATIVE 95) (DISABLEGC 96) (
COM-SETFILEINFO 103) (COM-OPENFILE 104) (COM-CLOSEFILE 105) (DSK-GETFILENAME 106) (DSK-DELETEFILE 107)
 (DSK-RENAMEFILE 108) (COM-NEXT-FILE 110) (COM-FINISH-FINFO 111) (COM-GEN-FILES 112) (
DSK-DIRECTORYNAMEP 113) (COM-GETFILEINFO 114) (COM-CHANGEDIR 116) (UNIX-HANDLECOMM 117) (RPC-CALL 119)
 (MESSAGE-READP 120) (MESSAGE-READ 121) (MONITOR-CONTROL 128) (GET-NATIVE-ADDR-FROM-LISP-PTR 131) (
GET-LISP-PTR-FROM-NATIVE-ADDR 132) (LOAD-NATIVE-FILE 133) (SUSPEND-LISP 134) (NEW-BLTCHAR 135) (
COLOR-INIT 136) (COLOR-SCREENMODE 137) (COLOR-MAP 138) (COLOR-BASE 139) (|C-SlowBltChar| 140) (
UNCOLORIZE-BITMAP 141) (COLORIZE-BITMAP 142) (COLOR-8BPPDRAWLINE 143) (TCP-OP 144) (WITH-SYMBOL 145) (
CAUSE-INTERRUPT 146) (OPEN-SOCKET 160) (CLOSE-SOCKET 161) (READ-SOCKET 162) (WRITE-SOCKET 163) (
CALL-C-FUNCTION 167) (DLD-LINK 168) (DLD-UNLINK-BY-FILE 169) (DLD-UNLINK-BY-SYMBOL 170) (
DLD-GET-SYMBOL 171) (DLD-GET-FUNC 172) (DLD-FUNCTION-EXECUTABLE-P 173) (DLD-LIST-UNDEFINED-SYMBOLS 174
) (C-MALLOC 175) (C-FREE 176) (C-PUTBASEBYTE 177) (C-GETBASEBYTE 178) (CHAR-OPENFILE 200) (CHAR-BIN 
201) (CHAR-BOUT 202) (CHAR-IOCTL 203) (CHAR-CLOSEFILE 204) (CHAR-EOFP 205) (CHAR-READP 206) (CHAR-BINS
 207) (CHAR-BOUTS 208) (CHAR-FILLBUFFER 209)))
(PUTPROP (QUOTE LLSUBRS) (QUOTE IMPORTDATE) (IDATE "17-Dec-1992 14:28:41"))

STOP

\ No newline at end of file
diff --git a/lispusers/MACINTERFACE b/lispusers/MACINTERFACE
index 2b9baacb..0190e570 100644
--- a/lispusers/MACINTERFACE
+++ b/lispusers/MACINTERFACE
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Feb-2021 14:01:07" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;78 20371  

      changes to%:  (VARS MACINTERFACECOMS)

      previous date%: "22-Feb-2021 12:56:21" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;77)


(PRETTYCOMPRINT MACINTERFACECOMS)

(RPAQQ MACINTERFACECOMS
       [
        (* ;; "Externals")

        (COMS (FNS MACWINDOW MACWINDOW.SETUP UNMACWINDOW MACWINDOW.UNSETUP)
              (INITVARS (MACWINDOWMARGIN 25)))
        
        (* ;; "Internals")

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

              (FNS MACINT-ADD-EXEC MACINT-SNAPW)
              (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL)
              (FNS TOTOPW.MACINTERFACE)
              (P (MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE)
                 (MOVD 'MACWINDOW 'MODERNWINDOW)
                 (MOVD 'UNMACWINDOW 'UNMODERNWINDOW))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE)
                                                 
                                                 (* ;; "Inspector")

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

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

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

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

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

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

                                                 (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW)
                                                 
                                                 (* ;; "New execs")

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

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

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

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

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



(* ;; "Externals")

(DEFINEQ

(MACWINDOW
  [LAMBDA (WINDOW ANYWHERE)                             (* ; "Edited 23-Jun-2020 16:01 by rmk:")

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

    (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)
        (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN))
        (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE
                                              THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE)
                                            ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN))))
    WINDOW])

(MACWINDOW.SETUP
  [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE)                 (* ; "Edited 13-Feb-2021 19:53 by rmk:")

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

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

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

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

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

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

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

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

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

(UNMACWINDOW
  [LAMBDA (WINDOW)                                      (* ; "Edited  7-Dec-2020 17:57 by rmk:")

    (* ;; "Restores original window behavior")

    (CL:WHEN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)
        (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN))
        (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN NIL))
    WINDOW])

(MACWINDOW.UNSETUP
  [LAMBDA (ORIGFN)                                      (* ; "Edited  6-Jul-2020 13:04 by rmk:")
                                                            (* ; "Edited 24-Jun-2020 15:09 by rmk:")

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

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

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

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

(RPAQ? MACWINDOWMARGIN 25)



(* ;; "Internals")

(DEFINEQ

(MACWINDOW.BUTTONEVENTFN
  [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE)                (* ; "Edited 14-Feb-2021 21:51 by rmk:")
                                                            (* ; "Edited 24-Jun-2020 20:23 by rmk:")
                                                            (* ; "Edited 23-May-2020 08:34 by rmk:")
                                                            (* ; "Edited 10-May-2020 03:35 by rmk:")
                                                            (* ; "Edited  3-May-2020 21:18 by rmk:")
    (IF (AND (MOUSESTATE (ONLY LEFT))
                 (EQ LASTKEYBOARD 0))
        THEN (TOTOPW WINDOW)
              (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION))
                          (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW]

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

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

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

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

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

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

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

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

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

(MACWINDOW.BUTTONEVENTFN.ANYWHERE
  [LAMBDA (WINDOW)                                      (* ; "Edited  3-Dec-2020 14:24 by rmk:")
                                                            (* ; "Edited 24-Jun-2020 13:24 by rmk:")

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

    (MACWINDOW.BUTTONEVENTFN WINDOW NIL T])

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

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

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

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

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

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

(INCORNER.REGION
  [LAMBDA (MAINREGION TOPMARGIN)                        (* ; "Edited 12-Feb-2021 23:22 by rmk:")

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

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

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



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

(DEFINEQ

(MACINT-ADD-EXEC
  [LAMBDA U                                             (* ; "Edited 24-Jun-2020 14:23 by rmk:")
    (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC)
                       (FOR N FROM 1 TO U COLLECT (ARG U N]

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

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

(MACINT-SNAPW
  [LAMBDA NIL                                           (* ; "Edited 24-Jun-2020 13:19 by rmk:")

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

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

    (LET ((W (MACORIG-SNAPW)))
         [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W)
                                                  (TOTOPW W)
                                                  (MOVEW W]
         W])
)
(DEFINEQ

(TEDIT.MACINTERFACE
  [LAMBDA NIL                                           (* ; "Edited 22-Feb-2021 12:56 by rmk:")
    (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN)
        (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN)

        (* ;; "All")

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

        (* ;; "Quit")

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

(TEDIT.SELECTALL
  [LAMBDA (STREAM TEXTOBJ SEL)                          (* ; "Edited  3-May-2020 17:29 by rmk:")
    (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS]
         (CL:WHEN TEXTSTREAM
             (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM)))
                    'LEFT))])
)
(DEFINEQ

(TOTOPW.MACINTERFACE
  [LAMBDA (WINDOW)                                      (* ; "Edited 13-Feb-2021 23:27 by rmk:")

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

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

(MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE)

(MOVD 'MACWINDOW 'MODERNWINDOW)

(MOVD 'UNMACWINDOW 'UNMODERNWINDOW)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(TEDIT.MACINTERFACE)


(* ;; "Inspector")


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


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


                                                             (* (MACWINDOW.SETUP
                                                           (QUOTE ONEDINSPECT.BUTTONEVENTFN)))

(MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN)


(* ;; "Freemenu")


(MACWINDOW.SETUP '\FM.BUTTONEVENTFN)


(* ;; "SEDIT")


(MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN)


(* ;; "Debugger")


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


(* ;; "Snap")


(MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW)


(* ;; "New execs")


(MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC)


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


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


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


(MACWINDOW.SETUP 'TB.BUTTONEVENTFN)


(* ;; "Grapher")


(MACWINDOW.SETUP 'APPLYTOSELECTEDNODE)


(* ;; "Promptwindow")


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

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA MACINT-ADD-EXEC)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4238 7997 (MACWINDOW 4248 . 4889) (MACWINDOW.SETUP 4891 . 6807) (UNMACWINDOW 6809 . 
7188) (MACWINDOW.UNSETUP 7190 . 7995)) (8057 16239 (MACWINDOW.BUTTONEVENTFN 8067 . 13089) (
MACWINDOW.BUTTONEVENTFN.ANYWHERE 13091 . 13456) (NEARTOP 13458 . 13894) (NEARESTCORNER 13896 . 14775) 
(INCORNER.REGION 14777 . 16237)) (16297 17274 (MACINT-ADD-EXEC 16307 . 16731) (MACINT-SNAPW 16733 . 
17272)) (17275 18358 (TEDIT.MACINTERFACE 17285 . 18027) (TEDIT.SELECTALL 18029 . 18356)) (18359 18799 
(TOTOPW.MACINTERFACE 18369 . 18797)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Feb-2021 14:01:07" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;78 20371  

      changes to%:  (VARS MACINTERFACECOMS)

      previous date%: "22-Feb-2021 12:56:21" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>MACINTERFACE.;77)


(PRETTYCOMPRINT MACINTERFACECOMS)

(RPAQQ MACINTERFACECOMS
       [
        (* ;; "Externals")

        (COMS (FNS MACWINDOW MACWINDOW.SETUP UNMACWINDOW MACWINDOW.UNSETUP)
              (INITVARS (MACWINDOWMARGIN 25)))
        
        (* ;; "Internals")

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

              (FNS MACINT-ADD-EXEC MACINT-SNAPW)
              (FNS TEDIT.MACINTERFACE TEDIT.SELECTALL)
              (FNS TOTOPW.MACINTERFACE)
              (P (MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE)
                 (MOVD 'MACWINDOW 'MODERNWINDOW)
                 (MOVD 'UNMACWINDOW 'UNMODERNWINDOW))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (TEDIT.MACINTERFACE)
                                                 
                                                 (* ;; "Inspector")

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

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

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

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

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

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

                                                 (MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW)
                                                 
                                                 (* ;; "New execs")

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

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

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

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

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



(* ;; "Externals")

(DEFINEQ

(MACWINDOW
  [LAMBDA (WINDOW ANYWHERE)                             (* ; "Edited 23-Jun-2020 16:01 by rmk:")

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

    (CL:UNLESS (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)
        (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN (WINDOWPROP WINDOW 'BUTTONEVENTFN))
        (WINDOWPROP WINDOW 'BUTTONEVENTFN (IF ANYWHERE
                                              THEN (FUNCTION MACWINDOW.BUTTONEVENTFN.ANYWHERE)
                                            ELSE (FUNCTION MACWINDOW.BUTTONEVENTFN))))
    WINDOW])

(MACWINDOW.SETUP
  [LAMBDA (ORIGFN MACWINDOWFN ANYWHERE)                 (* ; "Edited 13-Feb-2021 19:53 by rmk:")

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

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

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

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

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

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

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

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

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

(UNMACWINDOW
  [LAMBDA (WINDOW)                                      (* ; "Edited  7-Dec-2020 17:57 by rmk:")

    (* ;; "Restores original window behavior")

    (CL:WHEN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN)
        (WINDOWPROP WINDOW 'BUTTONEVENTFN (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN))
        (WINDOWPROP WINDOW 'PREMACBUTTONEVENTFN NIL))
    WINDOW])

(MACWINDOW.UNSETUP
  [LAMBDA (ORIGFN)                                      (* ; "Edited  6-Jul-2020 13:04 by rmk:")
                                                            (* ; "Edited 24-Jun-2020 15:09 by rmk:")

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

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

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

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

(RPAQ? MACWINDOWMARGIN 25)



(* ;; "Internals")

(DEFINEQ

(MACWINDOW.BUTTONEVENTFN
  [LAMBDA (WINDOW ORIGFUNCTION ANYWHERE)                (* ; "Edited 14-Feb-2021 21:51 by rmk:")
                                                            (* ; "Edited 24-Jun-2020 20:23 by rmk:")
                                                            (* ; "Edited 23-May-2020 08:34 by rmk:")
                                                            (* ; "Edited 10-May-2020 03:35 by rmk:")
                                                            (* ; "Edited  3-May-2020 21:18 by rmk:")
    (IF (AND (MOUSESTATE (ONLY LEFT))
                 (EQ LASTKEYBOARD 0))
        THEN (TOTOPW WINDOW)
              (LET [CORNER TOPMARGIN (MAINREGION (WINDOWPROP WINDOW 'REGION))
                          (ATTACHEDREGION (WINDOWREGION WINDOW 'SHAPEW]

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

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

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

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

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

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

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

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

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

(MACWINDOW.BUTTONEVENTFN.ANYWHERE
  [LAMBDA (WINDOW)                                      (* ; "Edited  3-Dec-2020 14:24 by rmk:")
                                                            (* ; "Edited 24-Jun-2020 13:24 by rmk:")

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

    (MACWINDOW.BUTTONEVENTFN WINDOW NIL T])

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

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

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

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

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

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

(INCORNER.REGION
  [LAMBDA (MAINREGION TOPMARGIN)                        (* ; "Edited 12-Feb-2021 23:22 by rmk:")

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

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

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



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

(DEFINEQ

(MACINT-ADD-EXEC
  [LAMBDA U                                             (* ; "Edited 24-Jun-2020 14:23 by rmk:")
    (LET [(PROC (APPLY (FUNCTION MACORIG-ADD-EXEC)
                       (FOR N FROM 1 TO U COLLECT (ARG U N]

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

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

(MACINT-SNAPW
  [LAMBDA NIL                                           (* ; "Edited 24-Jun-2020 13:19 by rmk:")

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

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

    (LET ((W (MACORIG-SNAPW)))
         [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (W)
                                                  (TOTOPW W)
                                                  (MOVEW W]
         W])
)
(DEFINEQ

(TEDIT.MACINTERFACE
  [LAMBDA NIL                                           (* ; "Edited 22-Feb-2021 12:56 by rmk:")
    (CL:WHEN (GETD '\TEDIT.BUTTONEVENTFN)
        (MACWINDOW.SETUP '\TEDIT.BUTTONEVENTFN)

        (* ;; "All")

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

        (* ;; "Quit")

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

(TEDIT.SELECTALL
  [LAMBDA (STREAM TEXTOBJ SEL)                          (* ; "Edited  3-May-2020 17:29 by rmk:")
    (LET [(TEXTSTREAM (TEXTSTREAM (TTY.PROCESS]
         (CL:WHEN TEXTSTREAM
             (TEDIT.SETSEL TEXTSTREAM 0 (ADD1 (fetch TEXTLEN of (TEXTOBJ TEXTSTREAM)))
                    'LEFT))])
)
(DEFINEQ

(TOTOPW.MACINTERFACE
  [LAMBDA (WINDOW)                                      (* ; "Edited 13-Feb-2021 23:27 by rmk:")

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

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

(MOVD 'TOTOPW.MACINTERFACE 'TOTOPW.MODERNIZE)

(MOVD 'MACWINDOW 'MODERNWINDOW)

(MOVD 'UNMACWINDOW 'UNMODERNWINDOW)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(TEDIT.MACINTERFACE)


(* ;; "Inspector")


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


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


                                                             (* (MACWINDOW.SETUP
                                                           (QUOTE ONEDINSPECT.BUTTONEVENTFN)))

(MACWINDOW.SETUP 'ICMLARRAY.TITLECOMMANDFN)


(* ;; "Freemenu")


(MACWINDOW.SETUP '\FM.BUTTONEVENTFN)


(* ;; "SEDIT")


(MACWINDOW.SETUP 'SEDIT::BUTTONEVENTFN)


(* ;; "Debugger")


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


(* ;; "Snap")


(MACWINDOW.SETUP 'SNAPW 'MACINT-SNAPW)


(* ;; "New execs")


(MACWINDOW.SETUP 'ADD-EXEC 'MACINT-ADD-EXEC)


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


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


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


(MACWINDOW.SETUP 'TB.BUTTONEVENTFN)


(* ;; "Grapher")


(MACWINDOW.SETUP 'APPLYTOSELECTEDNODE)


(* ;; "Promptwindow")


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

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA MACINT-ADD-EXEC)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4238 7997 (MACWINDOW 4248 . 4889) (MACWINDOW.SETUP 4891 . 6807) (UNMACWINDOW 6809 . 
7188) (MACWINDOW.UNSETUP 7190 . 7995)) (8057 16239 (MACWINDOW.BUTTONEVENTFN 8067 . 13089) (
MACWINDOW.BUTTONEVENTFN.ANYWHERE 13091 . 13456) (NEARTOP 13458 . 13894) (NEARESTCORNER 13896 . 14775) 
(INCORNER.REGION 14777 . 16237)) (16297 17274 (MACINT-ADD-EXEC 16307 . 16731) (MACINT-SNAPW 16733 . 
17272)) (17275 18358 (TEDIT.MACINTERFACE 17285 . 18027) (TEDIT.SELECTALL 18029 . 18356)) (18359 18799 
(TOTOPW.MACINTERFACE 18369 . 18797)))))
STOP
diff --git a/lispusers/MACINTERFACE.LCOM b/lispusers/MACINTERFACE.LCOM
index c01be2b8..71a2a9ee 100644
Binary files a/lispusers/MACINTERFACE.LCOM and b/lispusers/MACINTERFACE.LCOM differ
diff --git a/lispusers/WHEELSCROLL b/lispusers/WHEELSCROLL
index db277f2a..48007aae 100644
--- a/lispusers/WHEELSCROLL
+++ b/lispusers/WHEELSCROLL
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Feb-2021 09:47:46" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;43 7259   

      changes to%:  (VARS WHEELSCROLLCOMS)
                    (FNS ENABLEWHEELSCROLL)

      previous date%: "21-Feb-2021 09:39:06" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42)


(PRETTYCOMPRINT WHEELSCROLLCOMS)

(RPAQQ WHEELSCROLLCOMS
       [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL 
             LISPINTERRUPTS.WHEELSCROLL)
        [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
                                            T)
                                       (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
                                            T)
                                       (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA)
                                                   T))
                                       (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T]
        (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
        (INITVARS (WHEELSCROLLDELTA 20)
               (WHEELSCROLLSETTLETIME 50)
               (\WHEELSCROLLINPROGRESS NIL))
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL)
                                           (ENABLEWHEELSCROLL T])
(DEFINEQ

(ENABLEWHEELSCROLL
  [LAMBDA (ON)                                      (* ; "Edited 22-Feb-2021 09:47 by rmk:")

    (* ;; "So we can toggle this scrolling, for experimentation.")

    (IF ON
        THEN [KEYACTION 'PAD1 '((520 520) . IGNORE]
              [KEYACTION 'PAD2 '((521 521) . IGNORE]
              [KEYACTION 'PAD4 '((522 522) . IGNORE]
              [KEYACTION 'PAD5 '((523 523) . IGNORE]
      ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE))
            (KEYACTION 'PAD2 '(IGNORE . IGNORE))
            (KEYACTION 'PAD4 '(IGNORE . IGNORE))
            (KEYACTION 'PAD5 '(IGNORE . IGNORE])

(WHEELSCROLL
  [LAMBDA (DIRECTION DELTA)                             (* ; "Edited 21-Feb-2021 09:38 by rmk:")

    (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button.  And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button.  We don't yet have a good solution to this problem.  (This is not an issue with a trackpad)")

    (* ;; "")

    (CL:WHEN (MOUSESTATE UP)                                 (* ; 
                                                           "Ignore interrupt if a button is down")
        [LET ((W (WHICHW)))

         (* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within 
       the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))

             (CL:WHEN W

                 (* ;; "We scroll only if the window has a scrollfn.  Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL.  Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")

                 (IF (WINDOWPROP W 'SCROLLFN)
                     THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
                                     (CL:IF (EQ DIRECTION 'VERTICAL)
                                         `(WHEELSCROLL.DOIT ,(KWOTE W)
                                                 0
                                                 ,DELTA)
                                         `(WHEELSCROLL.DOIT ,(KWOTE W)
                                                 ,DELTA 0))]
                   ELSEIF (EQ DIRECTION 'VERTICAL)
                     THEN 

                           (* ;; "We are in a pop-up scrollbar.  This moves the cursor there, the user has to click to scroll the main window.")

                           (CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR)
                               (\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA))
                               (GETMOUSESTATE))
                   ELSEIF (EQ DIRECTION 'HORIZONTAL)
                     THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
                                  (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX)
                                         LASTMOUSEY)
                                  (GETMOUSESTATE))))])])

(WHEELSCROLL.DOIT
  [LAMBDA (WINDOW DX DY)                                (* ; "Edited 20-Feb-2021 17:34 by rmk:")

    (* ;; "This does the actual wheel scrolling, runing in the mouse process.")

    (* ;; "There have been instances where the window gets garbled as the wheel moves.  The hypothesis is that this is because the wheel moves so fast that another scroll starts before a previous one completes.")

    (* ;; "The global variable \WHEELSCROLLINPROGRESS is set to prevent that interference.")

    (CL:UNLESS \WHEELSCROLLINPROGRESS
        (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))])

(INSTALL-WHEELSCROLL
  [LAMBDA NIL                                           (* ; "Edited 17-Feb-2021 11:53 by rmk:")
    (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
        (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
        (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS))
    (FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I)
                                                          (CADR I)
                                                          (CADDR I))
                                                  (CL:WHEN (BOUNDP 'TEDIT.READTABLE)

                                                (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")

                                                      (TEDIT.SETFUNCTION (CAR I)
                                                             `[LAMBDA NIL
                                                                ,(CADR I]
                                                             TEDIT.READTABLE))])

(LISPINTERRUPTS.WHEELSCROLL
  [LAMBDA NIL                                           (* ; "Edited 17-Feb-2021 11:09 by rmk:")

    (* ;; "So wheelscroll interrupts will be installed in every process")

    (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG])
)

(RPAQQ WHEELSCROLLINTERRUPTS
       ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
             T)
        (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
             T)
        (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA)
                    T))
        (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
)

(RPAQ? WHEELSCROLLDELTA 20)

(RPAQ? WHEELSCROLLSETTLETIME 50)

(RPAQ? \WHEELSCROLLINPROGRESS NIL)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(INSTALL-WHEELSCROLL)

(ENABLEWHEELSCROLL T)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1432 6591 (ENABLEWHEELSCROLL 1442 . 2071) (WHEELSCROLL 2073 . 4609) (WHEELSCROLL.DOIT 
4611 . 5247) (INSTALL-WHEELSCROLL 5249 . 6312) (LISPINTERRUPTS.WHEELSCROLL 6314 . 6589)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Feb-2021 09:47:46" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;43 7259   

      changes to%:  (VARS WHEELSCROLLCOMS)
                    (FNS ENABLEWHEELSCROLL)

      previous date%: "21-Feb-2021 09:39:06" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>WHEELSCROLL.;42)


(PRETTYCOMPRINT WHEELSCROLLCOMS)

(RPAQQ WHEELSCROLLCOMS
       [(FNS ENABLEWHEELSCROLL WHEELSCROLL WHEELSCROLL.DOIT INSTALL-WHEELSCROLL 
             LISPINTERRUPTS.WHEELSCROLL)
        [VARS (WHEELSCROLLINTERRUPTS '((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
                                            T)
                                       (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
                                            T)
                                       (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA)
                                                   T))
                                       (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T]
        (GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
        (INITVARS (WHEELSCROLLDELTA 20)
               (WHEELSCROLLSETTLETIME 50)
               (\WHEELSCROLLINPROGRESS NIL))
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INSTALL-WHEELSCROLL)
                                           (ENABLEWHEELSCROLL T])
(DEFINEQ

(ENABLEWHEELSCROLL
  [LAMBDA (ON)                                      (* ; "Edited 22-Feb-2021 09:47 by rmk:")

    (* ;; "So we can toggle this scrolling, for experimentation.")

    (IF ON
        THEN [KEYACTION 'PAD1 '((520 520) . IGNORE]
              [KEYACTION 'PAD2 '((521 521) . IGNORE]
              [KEYACTION 'PAD4 '((522 522) . IGNORE]
              [KEYACTION 'PAD5 '((523 523) . IGNORE]
      ELSE (KEYACTION 'PAD1 '(IGNORE . IGNORE))
            (KEYACTION 'PAD2 '(IGNORE . IGNORE))
            (KEYACTION 'PAD4 '(IGNORE . IGNORE))
            (KEYACTION 'PAD5 '(IGNORE . IGNORE])

(WHEELSCROLL
  [LAMBDA (DIRECTION DELTA)                             (* ; "Edited 21-Feb-2021 09:38 by rmk:")

    (* ;; "The wheel may accidentally turn (giving the interrupt) when the users intention is simply to push the middle button.  And there may be another accidental turn (also giving an interrupt) when the user is releasing the middle button.  We don't yet have a good solution to this problem.  (This is not an issue with a trackpad)")

    (* ;; "")

    (CL:WHEN (MOUSESTATE UP)                                 (* ; 
                                                           "Ignore interrupt if a button is down")
        [LET ((W (WHICHW)))

         (* Unsuccessful a ttempt to suppress scroll if middlebutton comes down within 
       the setetle time (NOT (UNTILMOUSESTATE (ONLY MIDDLE) WHEELSCROLLSETTLETIME)))

             (CL:WHEN W

                 (* ;; "We scroll only if the window has a scrollfn.  Our behavior is thus different from a direct call to SCROLLW, which defaults to SCROLLBYREPAINTFN in that case, but conforms to what happens with IN/SCROLL/BAR? and SCROLL.HANDLER in WINDOWSCROLL.  Menus and scrollbars typically do not have scrollfns, so this suppresses otherwise funky behavior. ")

                 (IF (WINDOWPROP W 'SCROLLFN)
                     THEN [PROCESS.EVAL (FIND.PROCESS 'MOUSE)
                                     (CL:IF (EQ DIRECTION 'VERTICAL)
                                         `(WHEELSCROLL.DOIT ,(KWOTE W)
                                                 0
                                                 ,DELTA)
                                         `(WHEELSCROLL.DOIT ,(KWOTE W)
                                                 ,DELTA 0))]
                   ELSEIF (EQ DIRECTION 'VERTICAL)
                     THEN 

                           (* ;; "We are in a pop-up scrollbar.  This moves the cursor there, the user has to click to scroll the main window.")

                           (CL:WHEN (WINDOWPROP W 'VERTICALSCROLLBARFOR)
                               (\CURSORPOSITION LASTMOUSEX (IPLUS LASTMOUSEY DELTA))
                               (GETMOUSESTATE))
                   ELSEIF (EQ DIRECTION 'HORIZONTAL)
                     THEN (CL:WHEN (WINDOWPROP W 'HORIZONTALSCROLLBARFOR)
                                  (\CURSORPOSITION (IPLUS DELTA LASTMOUSEX)
                                         LASTMOUSEY)
                                  (GETMOUSESTATE))))])])

(WHEELSCROLL.DOIT
  [LAMBDA (WINDOW DX DY)                                (* ; "Edited 20-Feb-2021 17:34 by rmk:")

    (* ;; "This does the actual wheel scrolling, runing in the mouse process.")

    (* ;; "There have been instances where the window gets garbled as the wheel moves.  The hypothesis is that this is because the wheel moves so fast that another scroll starts before a previous one completes.")

    (* ;; "The global variable \WHEELSCROLLINPROGRESS is set to prevent that interference.")

    (CL:UNLESS \WHEELSCROLLINPROGRESS
        (RESETVAR \WHEELSCROLLINPROGRESS T (SCROLLW WINDOW DX DY)))])

(INSTALL-WHEELSCROLL
  [LAMBDA NIL                                           (* ; "Edited 17-Feb-2021 11:53 by rmk:")
    (CL:WHEN (GETD 'LISPINTERRUPTS.WHEELSCROLL)
        (MOVD? 'LISPINTERRUPTS 'LISPINTERRUPTS.WSORIG)
        (MOVD 'LISPINTERRUPTS.WHEELSCROLL 'LISPINTERRUPTS))
    (FOR I IN WHEELSCROLLINTERRUPTS DO (INTERRUPTCHAR (CAR I)
                                                          (CADR I)
                                                          (CADDR I))
                                                  (CL:WHEN (BOUNDP 'TEDIT.READTABLE)

                                                (* ;; "These actions are invoked when the caret is in the Tedit window, because TEDIT disables the interrupts")

                                                      (TEDIT.SETFUNCTION (CAR I)
                                                             `[LAMBDA NIL
                                                                ,(CADR I]
                                                             TEDIT.READTABLE))])

(LISPINTERRUPTS.WHEELSCROLL
  [LAMBDA NIL                                           (* ; "Edited 17-Feb-2021 11:09 by rmk:")

    (* ;; "So wheelscroll interrupts will be installed in every process")

    (APPEND WHEELSCROLLINTERRUPTS (LISPINTERRUPTS.WSORIG])
)

(RPAQQ WHEELSCROLLINTERRUPTS
       ((520 (WHEELSCROLL 'VERTICAL WHEELSCROLLDELTA)
             T)
        (521 (WHEELSCROLL 'VERTICAL (IMINUS WHEELSCROLLDELTA))
             T)
        (522 (WHEELSCROLL 'HORIZONTAL (IMINUS WHEELSCROLLDELTA)
                    T))
        (523 (WHEELSCROLL 'HORIZONTAL WHEELSCROLLDELTA T))))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS WHEELSCROLLDELTA WHEELSCROLLSETTLETIME \WHEELSCROLLINPROGRESS)
)

(RPAQ? WHEELSCROLLDELTA 20)

(RPAQ? WHEELSCROLLSETTLETIME 50)

(RPAQ? \WHEELSCROLLINPROGRESS NIL)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(INSTALL-WHEELSCROLL)

(ENABLEWHEELSCROLL T)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1432 6591 (ENABLEWHEELSCROLL 1442 . 2071) (WHEELSCROLL 2073 . 4609) (WHEELSCROLL.DOIT 
4611 . 5247) (INSTALL-WHEELSCROLL 5249 . 6312) (LISPINTERRUPTS.WHEELSCROLL 6314 . 6589)))))
STOP
diff --git a/lispusers/WHEELSCROLL.LCOM b/lispusers/WHEELSCROLL.LCOM
index 0c1e49d7..97812037 100644
Binary files a/lispusers/WHEELSCROLL.LCOM and b/lispusers/WHEELSCROLL.LCOM differ
diff --git a/loadups/WHEREIS.HASH b/loadups/WHEREIS.HASH
index ff8d8d38..f69841ab 100644
Binary files a/loadups/WHEREIS.HASH and b/loadups/WHEREIS.HASH differ
diff --git a/loadups/full.sysout b/loadups/full.sysout
new file mode 100644
index 00000000..c237f85f
Binary files /dev/null and b/loadups/full.sysout differ
diff --git a/loadups/lisp.sysout b/loadups/lisp.sysout
new file mode 100644
index 00000000..a246472c
Binary files /dev/null and b/loadups/lisp.sysout differ
diff --git a/run-medley b/run-medley
index 75b061d3..609fd874 100755
--- a/run-medley
+++ b/run-medley
@@ -82,15 +82,19 @@ while [ "$#" -ne 0 ]; do
             export DISPLAY="$2"
             shift
             ;;
+	"-prog" )
+	    prog="$2"
+	    shift
+	    ;;
         "-vmem" | "--vmem" | "-vmfile" )
             export LDEDESTSYSOUT="$2"
             shift
             ;;
         "-full")
-            export LDESRCESYSOUT="$MEDLEYDIR/loadups/xfull35.sysout"
+            export LDESRCESYSOUT="$MEDLEYDIR/loadups/full.sysout"
             ;;
         "-lisp")
-            export LDESRCESYSOUT="$MEDLEYDIR/loadups/xlisp.sysout"
+            export LDESRCESYSOUT="$MEDLEYDIR/loadups/lisp.sysout"
             ;;
         "-*")
             passthrough_args="$passthrough_args $1 $2"
@@ -162,6 +166,6 @@ echo "start $LDEINIT"
 
 export INMEDLEY=1
 
-$prog $geometry $screensize -t "Medley Interlisp" $passthrough_args "$LDESRCESYSOUT"
+$prog $geometry $screensize -m 256 -t "Medley Interlisp" $passthrough_args "$LDESRCESYSOUT"
 
 
diff --git a/scripts/loadup-all.sh b/scripts/loadup-all.sh
new file mode 100755
index 00000000..ee96265f
--- /dev/null
+++ b/scripts/loadup-all.sh
@@ -0,0 +1,12 @@
+#!/bin/sh
+
+export MEDLEYDIR=`pwd`
+
+if [ ! -x run-medley ] ; then
+    echo run from MEDLEYDIR
+    exit 1
+fi
+
+./scripts/loadup-init.sh && ./scripts/loadup-mid-from-init.sh && ./scripts/loadup-lisp-from-mid.sh && ./scripts/loadup-full.sh
+
+echo tada!
diff --git a/scripts/loadup-full.sh b/scripts/loadup-full.sh
index c17c4016..f2223a96 100755
--- a/scripts/loadup-full.sh
+++ b/scripts/loadup-full.sh
@@ -2,13 +2,17 @@
 
 export MEDLEYDIR=`pwd`
 
-if [ ! -f run-medley ] ; then
+if [ ! -x run-medley ] ; then
     echo must run from MEDLEYDIR ;
     exit 1 ;
 fi
+scr="-sc 1024x768 -g 1042x790"
 
-export LOADUPDIR=$MEDLEYDIR
+rm -f ~/rem.cm
 
-./run-medley -greet $MEDLEYDIR/sources/LOADUP-FULL.LCOM $MEDLEYDIR/loadups/xlisp.sysout
+./run-medley $scr -greet $MEDLEYDIR/sources/LOADUP-FULL.LCOM $MEDLEYDIR/loadups/lisp.sysout
 
 
+echo ----- made ----
+ls -l loadups/full.sysout
+echo ---------------
diff --git a/scripts/loadup-init.sh b/scripts/loadup-init.sh
new file mode 100755
index 00000000..94c894a6
--- /dev/null
+++ b/scripts/loadup-init.sh
@@ -0,0 +1,18 @@
+#!/bin/sh
+
+export MEDLEYDIR=`pwd`
+
+if [ ! -f run-medley ] ; then
+    echo run from MEDLEYDIR
+    exit 1
+fi
+
+scr="-sc 1024x768 -g 1042x790"
+
+mkdir -p "$MEDLEYDIR/tmp"
+
+./run-medley $scr -greet "$MEDLEYDIR"/sources/LOADUP-INIT.LISP -full
+
+echo ---- made ----
+ls -l tmp loadups/init*
+echo --------------
diff --git a/scripts/loadup-lisp-from-mid.sh b/scripts/loadup-lisp-from-mid.sh
new file mode 100755
index 00000000..1721ea5d
--- /dev/null
+++ b/scripts/loadup-lisp-from-mid.sh
@@ -0,0 +1,18 @@
+#!/bin/sh
+
+export MEDLEYDIR=`pwd`
+
+if [ ! -f run-medley ] ; then
+    echo run from MEDLEYDIR
+    exit 1
+fi
+
+scr="-sc 1024x768 -g 1042x790"
+
+
+./run-medley $scr -greet $MEDLEYDIR/sources/YREM.CM tmp/init-mid.sysout
+
+echo ----- created: -------
+ls -l loadups/lisp.sysout
+echo ----------------------
+
diff --git a/scripts/loadup-lisp.sh b/scripts/loadup-lisp.sh
deleted file mode 100755
index 7238b09b..00000000
--- a/scripts/loadup-lisp.sh
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/sh
-
-export MEDLEYDIR=`pwd`
-
-if [ ! -f run-medley ] ; then
-    echo run from MEDLEYDIR
-    exit 1
-fi
-
-export LOADUPDIR=$MEDLEYDIR
-
-./run-medley -greet $MEDLEYDIR/sources/LOADUP-LISP.LCOM $MEDLEYDIR/loadups/lisp.venuesysout
diff --git a/scripts/loadup-mid-from-init.sh b/scripts/loadup-mid-from-init.sh
new file mode 100755
index 00000000..481a7139
--- /dev/null
+++ b/scripts/loadup-mid-from-init.sh
@@ -0,0 +1,17 @@
+#!/bin/sh
+
+export MEDLEYDIR=`pwd`
+
+if [ ! -x run-medley ] ; then
+    echo run from MEDLEYDIR
+    exit 1
+fi
+
+mkdir -p "$MEDLEYDIR/tmp"
+scr="-sc 1024x768 -g 1042x790"
+
+./run-medley -prog ldeinit -greet $MEDLEYDIR/sources/XREM.CM $scr -vmem tmp/init-mid.sysout loadups/init.dlinit
+
+echo ---- made ----
+ls -l tmp/
+echo --------------
diff --git a/sources/ACODE.LCOM b/sources/ACODE.LCOM
index 6ed361eb..032d6daf 100644
Binary files a/sources/ACODE.LCOM and b/sources/ACODE.LCOM differ
diff --git a/sources/ADIR b/sources/ADIR
index 35819d67..98808193 100644
--- a/sources/ADIR
+++ b/sources/ADIR
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "14-Oct-2020 11:14:03" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ADIR.;7 48306  

      changes to%:  (FNS SYSOUT)

      previous date%: "14-Oct-2020 10:54:03" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ADIR.;6)


(* ; "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1920, 2017, 2020 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ADIRCOMS)

(RPAQQ ADIRCOMS [[COMS                                   (* ; "user-level i/o routines")
                           (FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE 
                                OUTFILEP RENAMEFILE SIMPLE.FINDFILE)
                           (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T))
                           (P (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T))
                           (DECLARE%: DONTEVAL@LOAD DOCOPY (P 

                                       (* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM.  PATHNAMEP (and pathnames) get defined much later in the loadup.")

                                                              (MOVD? 'NILL 'CL:PATHNAMEP]
                     (COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS 
                                \UPF.TEMPFILEP FILENAMEFIELD PACKFILENAME PACKFILENAME.STRING)
                           (DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY 
                                                      PACKFILENAME.ASSEMBLE UNPACKFILE1))
                           (VARS \FILENAME.SYNTAX)
                           (GLOBALVARS \FILENAME.SYNTAX))
                     (COMS                                   (* ; 
                                                           "saving and restoring system state")
                           (FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT)
                           (ADDVARS (AROUNDEXITFNS))
                           (INITVARS (HERALDSTRING "")
                                  (\USERNAME))
                           (GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS)
                           (FNS USERNAME SETUSERNAME))
                     (LOCALVARS . T)
                     (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                                             FILEIO))
                     (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
                            (ADDVARS (NLAMA)
                                   (NLAML)
                                   (LAMA PACKFILENAME.STRING PACKFILENAME])



(* ; "user-level i/o routines")

(DEFINEQ

(DELFILE
(LAMBDA (FILE) (* bvm%: "23-Oct-85 11:20") (AND FILE (NEQ FILE T) (\DELETEFILE FILE))))

(FULLNAME
(LAMBDA (X RECOG) (* rmk%: "22-AUG-83 13:33") (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T (SELECTQ RECOG (NIL (SETQQ RECOG OLD)) ((OLD OLD/NEW NEW OLDEST)) (\ILLEGAL.ARG RECOG)) (\GETFILENAME X RECOG))))
)

(INFILE
(LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:23") (INPUT (OPENFILE FILE (QUOTE INPUT) (QUOTE OLD)))))

(INFILEP
(LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") (\GETFILENAME FILE (QUOTE OLD))))

(IOFILE
(LAMBDA (FILE) (* rmk%: " 5-SEP-81 13:54") (OPENFILE FILE (QUOTE BOTH) (QUOTE OLD))))

(OPENFILE
  [LAMBDA (FILE ACCESS RECOG PARAMETERS OPTIONAL)        (* ; "Edited 23-May-91 19:12 by jds")
    (if MULTIPLE.STREAMS.PER.FILE.ALLOWED
        then (OPENSTREAM FILE ACCESS RECOG PARAMETERS OPTIONAL)
      else (fetch (STREAM FULLNAME) of (OPENSTREAM FILE ACCESS RECOG PARAMETERS 
                                                          OPTIONAL])

(OPENSTREAM
(LAMBDA (FILE ACCESS RECOG PARAMETERS OBSOLETE) (* hdj "28-Aug-86 14:50") (PROG (REC OLDSTREAM STREAM) (SELECTQ ACCESS ((INPUT OUTPUT BOTH APPEND)) (\ILLEGAL.ARG ACCESS)) (SETQ REC (SELECTQ RECOG ((EXACT NEW OLD OLD/NEW OLDEST) RECOG) (NIL (SELECTQ ACCESS (INPUT (QUOTE OLD)) (OUTPUT (QUOTE NEW)) (QUOTE OLD/NEW))) (\ILLEGAL.ARG RECOG))) (if (OR (LISTP OBSOLETE) (AND PARAMETERS (NLISTP PARAMETERS))) then (* ;; "used to have OPENFILE/OPENSTREAM with BYTESIZE and PARAMETERS.  Now it will take PARAMETERS, and generally ignore the BYTESIZE") (SETQ PARAMETERS (APPEND (SELECTQ PARAMETERS (7 (QUOTE ((TYPE TEXT)))) (8 (QUOTE ((TYPE BINARY)))) NIL) OBSOLETE))) (COND ((OR (EQ FILE T) (NULL FILE)) (* ;; "Handle T and NIL separately, cause they can return the terminal streams, for which the search isn't necessary and the \ADDOFD shouldn't be done.") (SETQ STREAM (\GETSTREAM FILE ACCESS)) (\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS) (RETURN STREAM))) (* ;; "Explicitly test for PATHNAMEP, as PATHNAMEP will have a NILL def early in the loadup, and the tests in \CONVERT-PATHNAME won't break anything") (* ;; "Pavel changed a call to (PATHNAMEP FILE) into (TYPEP FILE `PATHNAME) because PATHNAMEP didn't have a NILL defn early in the loadup and TYPEP has an optimizer on it that compiles away the call to TYPEP which also has no defn early in the loadup.") (* ;; "Pavel also added the call to MKSTRING below as a temporary hack to get around the fact that the Interlisp string functions can't yet handle Common Lisp simple-strings.") (if (TYPEP FILE (QUOTE PATHNAME)) then (SETQ FILE (\CONVERT-PATHNAME FILE))) (* ;; "We open the file before looking to see whether it is already open.  This guarantees that we acquire the opening rights at the time we lookup the name.  We then check to see if it is currently open in Lisp.  If it is, we return the previous stream, which has the file's current state.  ") (* ;; "There are still potential problems: First, an interrupt can happen while we are doing the search which causes the file to be deleted or re-opened beneath us, BEFORE it gets added to \OPENFILES.  Second, a network device might not allow multiple openings of the file, even by the same guy with the same mode.") (SETQ STREAM (\OPENFILE FILE ACCESS REC PARAMETERS)) (COND ((AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED) (SETQ OLDSTREAM (\SEARCHOPENFILES (fetch FULLNAME of STREAM)))) (* ;; "There is already a stream open on the file.  Check that there is no conflict.  Eventually all this registration belongs in the device, so that we can have multiple streams open per file") (COND ((AND (EQ ACCESS (QUOTE INPUT)) (EQ (fetch ACCESS of OLDSTREAM) (QUOTE INPUT))) (* ; "Dispose of the newly-obtained stream, This might be a noop, but a network device (LEAF) cares") (OR (EQ STREAM OLDSTREAM) (\CLOSEFILE STREAM)) (\DO.PARAMS.AT.OPEN OLDSTREAM ACCESS PARAMETERS) (* ; "Do parameters on the old stream") (RETURN OLDSTREAM)) (T (LISPERROR "FILE WON'T OPEN" FILE)))) (T (AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED) (\ADDOFD STREAM)) (* ; "Parameters done on new stream by \OPENFILE") (RETURN STREAM)))))
)

(OUTFILE
(LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:24") (OUTPUT (OPENFILE FILE (QUOTE OUTPUT) (QUOTE NEW)))))

(OUTFILEP
(LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") (\GETFILENAME FILE (QUOTE NEW))))

(RENAMEFILE
(LAMBDA (OLDFILE NEWFILE) (* hdj " 4-Sep-86 16:56") (SETQ OLDFILE (\CONVERT-PATHNAME OLDFILE)) (SETQ NEWFILE (\CONVERT-PATHNAME NEWFILE)) (AND OLDFILE NEWFILE (NEQ OLDFILE T) (NEQ NEWFILE T) (\RENAMEFILE OLDFILE NEWFILE)))
)

(SIMPLE.FINDFILE
(LAMBDA (FILE DUMMY DIRLST) (* bvm%: "23-Oct-85 11:22") (OR (for DIR in DIRLST when (SETQ $$VAL (INFILEP (PACKFILENAME.STRING (QUOTE DIRECTORY) DIR (QUOTE BODY) FILE))) do (RETURN $$VAL)) (AND (NOT (MEMB NIL DIRLST)) (INFILEP FILE))))
)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ MULTIPLE.STREAMS.PER.FILE.ALLOWED T)


(CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T))
)

(MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T)
(DECLARE%: DONTEVAL@LOAD DOCOPY 


(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM.  PATHNAMEP (and pathnames) get defined much later in the loadup.")


(MOVD? 'NILL 'CL:PATHNAMEP)
)
(DEFINEQ

(UNPACKFILENAME
(LAMBDA (FILE ONEFIELDFLG OSTYPE) (* ; "Edited  6-Jan-88 13:13 by bvm:") (UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T))
)

(UNPACKFILENAME.STRING
(LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 30-Mar-90 22:37 by nm") (* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") (PROG ((POS 1) (LEN (NCHARS FILE)) TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI) (COND ((NULL FILE) (RETURN NIL)) ((OR (LITATOM FILE) (STRINGP FILE) (NUMBERP FILE))) ((TYPEP FILE (QUOTE PATHNAME)) (RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG))) ((STREAMP FILE) (* ; "For streams, use full name.  If anonymous, fake it") (SETQ FILE (OR (ffetch FULLFILENAME of FILE) (RETURN (COND (ONEFIELDFLG (AND (EQ ONEFIELDFLG (QUOTE NAME)) FILE)) (T (LIST (QUOTE NAME) FILE))))))) (T (\ILLEGAL.ARG FILE))) (COND ((SELCHARQ (NTHCHARCODE FILE 1) ({ (* ; "normal use in Interlisp-D") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE }) FILE 2) 0)))) (%[ (* ; "some Xerox and Arpanet systems use '[' for host") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]") FILE 2) 0)))) (%( (* ; "this is the 'proposed standard' for Xerox servers") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") FILE 2) 0)))) NIL) (UNPACKFILE1 (QUOTE HOST) 2 TEM) (COND ((EQ TEM -1) (* ; "Started with the host field delimiter, but there was no corresponding terminating delimiter .") (* ; "I'm not sure why the name is dealt with the host name.") (RETURN (DREVERSE VAL)))) (SETQ POS (IPLUS TEM 2)) (if (EQ OSTYPE T) then (* ; "Use actual host to determine os type") (SETQ OSTYPE (GETHOSTINFO (CAR VAL) (QUOTE OSTYPE)))) (SETQ HOSTP T))) (COND ((SETQ TEM (LASTCHPOS (CHARCODE %:) FILE POS)) (* ; "all device returned have DEVICE.END on it so that NIL: will work") (UNPACKFILE1 (QUOTE DEVICE) POS (if CLFLG then (SUB1 TEM) else TEM)) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (COND ((EQ DIRFLG (QUOTE RETURN)) (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter.  If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention.  In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.") (LET ((TYPE (QUOTE DIRECTORY)) (START (SELCHARQ (NTHCHARCODE FILE POS) (NIL (* ; "just host, return") (RETURN (DREVERSE VAL))) ((/ <) (* ; "Started with the initial directory delimiter.") (ADD1 POS)) POS)) END) (SETQ END (SELCHARQ (NTHCHARCODE FILE -1) ((/ >) (COND ((EQ START POS) (* ; "Didn't start with a directory delimiter,") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM.  This is a subdirectory of the current connected directory") (SETQ TYPE (QUOTE SUBDIRECTORY))) (T (* ; "True %"relative pathname%".  The way to deal with it is dependent on the device on which HOST is implemented.") (SETQ TYPE (QUOTE RELATIVEDIRECTORY)))))) (COND ((EQ LEN POS) (* ; "Only the initial directory is specified (i.e. %"{DSK}/%").") (SETQ START POS) -1) (T -2))) (PROGN (COND ((EQ START POS) (* ; "Both of the initial and trail delimiters are omitted.") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM.  This is a subdirectory of the current connected directory") (SETQ TYPE (QUOTE SUBDIRECTORY))) (T (* ; "True %"relative pathname%".  The way to deal with it is dependent on the device on which HOST is implemented.") (SETQ TYPE (QUOTE RELATIVEDIRECTORY))))) (T (COND ((EQ LEN POS) (* ; "Only the initial directory is specified (i.e. %"{DSK}<%").") (SETQ START POS))))) -1))) (UNPACKFILE1.DIRECTORY TYPE START END)) (RETURN (DREVERSE VAL))) ((SELCHARQ (NTHCHARCODE FILE POS) (/ (* ; "unix and the 'xerox standard' use / for delimiter") (* ; "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.") (SETQ TEM (LASTCHPOS (CHARCODE (/ >)) FILE (ADD1 POS))) T) ((< >) (* ; "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>.  Jericho uses >>") (* ; "In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.") (SETQ TEM (LASTCHPOS (CHARCODE (> /)) FILE (ADD1 POS))) T) NIL) (* ;; "allow {DSK}/etc   to be a directory specification.") (if TEM then (UNPACKFILE1.DIRECTORY (QUOTE DIRECTORY) (ADD1 POS) (SUB1 TEM)) (SETQ POS (ADD1 TEM)) else (* ;; "{DSK}/foo: the directory is /, the name is foo") (UNPACKFILE1.DIRECTORY (QUOTE DIRECTORY) POS POS) (SETQ POS (ADD1 POS))) (SETQ HOSTP T)) ((SETQ TEM (LASTCHPOS (CHARCODE (/ >)) FILE POS)) (* ; " {eris}abc>  relative") (* ;; " This is the true %"relative pathname%".  Returns RELATIVEDIRECTORY instead of DIRECTORY.") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case.") (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG (QUOTE FIELD)) then (QUOTE DIRECTORY) else (QUOTE SUBDIRECTORY)) POS (SUB1 TEM))) (T (* ; "True %"relative pathname%".") (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG (QUOTE FIELD)) then (QUOTE DIRECTORY) else (QUOTE RELATIVEDIRECTORY)) POS (SUB1 TEM)))) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS))) (RETURN (DREVERSE VAL))) (if (EQ OSTYPE T) then (* ; "There wasn't a host field in the name, so we have no clue") (SETQ OSTYPE NIL)) NAMELP (* ;; "At this point, CODE is the TEM'th char of file name.  POS is the first character of the field we are currently working on.") (SELCHARQ CODE (%. (* ; "Note position for later--we only want to deal with the last set of dots") (if BEYONDNAME then (* ; "no longer of interest (probably a bad name, too)") elseif FIRSTDOT then (* ; "We're recording the second dot") (if SECONDDOT then (* ; "Note only the two most recent dots") (SETQ FIRSTDOT SECONDDOT)) (SETQ SECONDDOT TEM) else (SETQ FIRSTDOT TEM))) ((! ; NIL) (* ; "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now") (if (SELCHARQ CODE (! (* ; "! is only a delimiter on IFS, so ignore it if we know the ostype is something else") (AND OSTYPE (NEQ OSTYPE (QUOTE IFS)))) (; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version.  Skip it unless it's ;T or ;S") (AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM))))) NIL) then (GO NEXTCHAR)) (if FIRSTDOT then (* ; "Have a name and/or extension to parse now") (if (AND SECONDDOT (NOT (if OSTYPE then (* ; "Known OS type must be Tops20 for second dot to mean version") (EQ OSTYPE (QUOTE TOPS20)) else (* ; "Unknown OS type, so check that %"version%" is numeric or wildcard") (AND (for I from (ADD1 SECONDDOT) to (SUB1 TEM) bind CH always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I))) (EQ CH (CHARCODE *)))) (SELCHARQ CODE (NIL (* ; "end of file name, ok") T) (; (* ; "This semi-colon better not be introducing a version") (\UPF.TEMPFILEP FILE (ADD1 TEM))) NIL))))) then (* ; "Second dot is not intoducing a version") (SETQ FIRSTDOT SECONDDOT) (SETQ SECONDDOT NIL)) (UNPACKFILE1 (QUOTE NAME) POS (SUB1 FIRSTDOT)) (SETQ POS (ADD1 (if SECONDDOT then (UNPACKFILE1 (QUOTE EXTENSION) (ADD1 FIRSTDOT) (SUB1 SECONDDOT)) (SETQ BEYONDEXT T) SECONDDOT else FIRSTDOT))) (SETQ BEYONDNAME T) (SETQ FIRSTDOT NIL)) (UNPACKFILE1 (COND ((NOT BEYONDNAME) (SETQQ BEYONDNAME NAME)) ((NOT BEYONDEXT) (QUOTE EXTENSION)) ((AND (EQ BEYONDEXT (CHARCODE ";")) (\UPF.TEMPFILEP FILE POS))) (T (* ; "Everything after the semi was version") (QUOTE VERSION))) POS (SUB1 TEM)) (if (NULL CODE) then (* ; "End of string") (RETURN (DREVERSE VAL))) (SETQ BEYONDEXT CODE) (* ; "Note the character that terminated the name/ext") (SETQ POS (ADD1 TEM))) (%' (* ; "Quoter") (add TEM 1)) NIL) NEXTCHAR (SETQ CODE (NTHCHARCODE FILE (add TEM 1))) (GO NAMELP)))
)

(LASTCHPOS
(LAMBDA (CH STR START) (* ; "Edited 17-May-88 13:43 by MASINTER") (PROG (RESULT NC) (OR START (SETQ START 1)) (while (SETQ NC (NTHCHARCODE STR START)) do (COND ((EQMEMB NC CH) (SETQ RESULT START)) ((EQ NC (CHARCODE %')) (add START 1))) (add START 1)) (RETURN RESULT)))
)

(\UPF.NEXTPOS
(LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41") (bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND ((EQMEMB NCH CHAR) (RETURN POS)) ((EQ NCH (CHARCODE %')) (add POS 1))) (add POS 1)))
)

(\UPF.TEMPFILEP
(LAMBDA (FILENAME START) (* ; "Edited  6-Jan-88 13:12 by bvm:") (* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START.  Returns the appropriate field name if so.  Not sure we should parse this junk any more, but this at least localizes it.") (SELCHARQ (NTHCHARCODE FILENAME START) ((T S) (* ; "Funny temp stuff") (AND (EQ START (NCHARS FILENAME)) (QUOTE TEMPORARY))) NIL))
)

(FILENAMEFIELD
(LAMBDA (FILE FIELDNAME) (* ; "Edited  6-Mar-90 19:38 by nm") (UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME ((VERSION GENERATION) (QUOTE VERSION)) ((DEVICE STRUCTURE) (QUOTE DEVICE)) FIELDNAME) (QUOTE FIELD) NIL T))
)

(PACKFILENAME
(LAMBDA N (* bvm%: " 5-Jul-85 15:40") (COND ((AND (EQ N 1) (LISTP (ARG N 1))) (* ; "spread argument list") (APPLY (FUNCTION PACKFILENAME) (ARG N 1))) (T (PACK (PACKFILENAME.ASSEMBLE)))))
)

(PACKFILENAME.STRING
(LAMBDA N (* bvm%: " 5-Jul-85 15:41") (COND ((AND (EQ N 1) (LISTP (ARG N 1))) (* ; "spread argument list") (APPLY (FUNCTION PACKFILENAME.STRING) (ARG N 1))) (T (CONCATLIST (PACKFILENAME.ASSEMBLE)))))
)
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTPROPS
 CANONICAL.DIRECTORY MACRO
 (OPENLAMBDA (SRCSTRING)
   (AND
    SRCSTRING
    (LET
     ((LEN (NCHARS SRCSTRING)))
     (COND
        ((EQ LEN 1)
         (if (STREQUAL SRCSTRING "/")
             then "<"
           else SRCSTRING))
        (T
         (LET* ((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING))
                (DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T)))
                (DSTBASE (ffetch (STRINGP BASE) of DSTSTRING))
                (DSTPOS 0)
                (NEXTPOS -1))
               (if (NOT FATP)
                   then [for SRCPOS from 1 to LEN bind CODE
                               first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
                                                           (CHARCODE (< / >)))
                                            do (add SRCPOS 1))
                                     (if (> SRCPOS LEN)
                                         then (RETURN "<"))
                               do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
                                           ((> /) 
                                                (if (> DSTPOS NEXTPOS)
                                                    then (\PUTBASETHIN DSTBASE DSTPOS
                                                                    (CHARCODE >))
                                                          (SETQ NEXTPOS (add DSTPOS 1))))
                                           (%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
                                               (add DSTPOS 1)
                                               (if (NEQ SRCPOS LEN)
                                                   then (\PUTBASETHIN DSTBASE DSTPOS
                                                                   (NTHCHARCODE SRCSTRING
                                                                          (add SRCPOS 1)))
                                                         (add DSTPOS 1)))
                                           (PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
                                                  (add DSTPOS 1)))
                               finally
                               (RETURN (if (EQ DSTPOS LEN)
                                           then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
                                                                   (CHARCODE (> /)))
                                                        then (SUBSTRING DSTSTRING 1 -2)
                                                      else DSTSTRING)
                                         elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
                                                           (CHARCODE (> /)))
                                           then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
                                         else (SUBSTRING DSTSTRING 1 DSTPOS]
                 else (for SRCPOS from 1 to LEN bind CODE
                             first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
                                                         (CHARCODE (< / >)))
                                          do (add SRCPOS 1))
                             do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
                                         ((> /) 
                                              (if (> DSTPOS NEXTPOS)
                                                  then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE
                                                                                        >))
                                                        (SETQ NEXTPOS (add DSTPOS 1))))
                                         (%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
                                             (add DSTPOS 1)
                                             (if (NEQ SRCPOS LEN)
                                                 then (\PUTBASEFAT DSTBASE DSTPOS
                                                                 (NTHCHARCODE SRCSTRING
                                                                        (add SRCPOS 1)))
                                                       (add DSTPOS 1)))
                                         (PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
                                                (add DSTPOS 1)))
                             finally (RETURN (if (EQ DSTPOS LEN)
                                                     then (if (EQMEMB (NTHCHARCODE DSTSTRING
                                                                                     -1)
                                                                             (CHARCODE (> /)))
                                                                  then (SUBSTRING DSTSTRING 1 -2)
                                                                else DSTSTRING)
                                                   elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
                                                                     (CHARCODE (> /)))
                                                     then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
                                                   else (SUBSTRING DSTSTRING 1 DSTPOS]

[PUTPROPS UNPACKFILE1.DIRECTORY MACRO (OPENLAMBDA (NAM ST END)
                                        (LET* ((OLDDIR (SUBSTRING FILE ST END))
                                               (NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
                                              (COND
                                                 [(NOT ONEFIELDFLG)
                                                  (SETQ VAL (CONS (COND
                                                                     (PACKFLG (AND NEWDIR
                                                                                   (MKATOM NEWDIR)))
                                                                     (T (OR NEWDIR "")))
                                                                  (CONS NAM VAL]
                                                 ((EQMEMB NAM ONEFIELDFLG)
                                                  (RETURN (COND
                                                             (PACKFLG (AND NEWDIR (MKATOM NEWDIR)))
                                                             (T (OR NEWDIR ""]

[PUTPROPS
 PACKFILENAME.ASSEMBLE MACRO
 (NIL (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY NAME EXTENSION VERSION 
             TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY NAME EXTENSION 
                                VERSION TEMPORARY PROTECTION ACCOUNT))
        LP  (COND
               ((<= I N)

                (* ;; "Grab the next field-name / value pair and fold it into the filename:")

                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((<= (SETQ I (ADD1 I))
                        N)
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (EQ VAR 'BODY)
                    (\ILLEGAL.ARG VAL))
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                             ((LISTP VAL)
                                                              (PACKFILENAME.STRING VAL))
                                                             (T VAL))
                                      NIL
                                      'OK)
                               [FUNCTION (LAMBDA (X)
                                           (SELECTQ (CAR X)
                                               (HOST (OR HOST (SETQ HOST (OR (CADR X)
                                                                             BLIP))))
                                               (DEVICE (OR DEVICE (SETQ DEVICE (OR (CADR X)
                                                                                   BLIP))))
                                               (DIRECTORY [OR DIRECTORY
                                                              (COND
                                                                 (RELATIVEDIRECTORY (SETQ DIRECTORY 
                                                                                     BLIP))
                                                                 (T (SETQ DIRECTORY
                                                                     (OR (CADR X)
                                                                         BLIP])
                                               (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                                               (OR (CADR X)
                                                                                   BLIP))))
                                               (RELATIVEDIRECTORY 
                                                    [OR RELATIVEDIRECTORY
                                                        (COND
                                                           (DIRECTORY (SETQ RELATIVEDIRECTORY BLIP))
                                                           (T (SETQ RELATIVEDIRECTORY
                                                               (OR (CADR X)
                                                                   BLIP])
                                               (NAME (OR NAME (SETQ NAME (OR (CADR X)
                                                                             BLIP))))
                                               (EXTENSION (OR EXTENSION (SETQ EXTENSION
                                                                         (OR (CADR X)
                                                                             BLIP))))
                                               (VERSION (OR VERSION (SETQ VERSION (OR (CADR X)
                                                                                      BLIP))))
                                               (SHOULDNT]
                               (FUNCTION CDDR)))
                    (HOST [OR HOST (SETQ HOST (COND
                                                 (VAL (SELCHARQ (CHCON1 VAL)
                                                           (({ %[ %() 
                                                                (SUBSTRING VAL 2
                                                                       (SELCHARQ (NTHCHARCODE VAL -1)
                                                                            ((} %] %)) 
                                                                                 -2)
                                                                            -1)))
                                                           VAL))
                                                 (T BLIP])
                    ((PATHNAME DIRECTORY) 
                         [COND
                            (VAL (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL
                                                                    'RETURN))
                                    by (CDDR X)
                                    do (SELECTQ (CAR X)
                                               (HOST [COND
                                                        ((NOT HOST)
                                                         (SETQ HOST (OR (CADR X)
                                                                        BLIP])
                                               (DEVICE [COND
                                                          ((NOT DEVICE)
                                                           (SETQ DEVICE (OR (CADR X)
                                                                            BLIP])
                                               (SUBDIRECTORY [OR DIRECTORY
                                                                 (COND
                                                                    (RELATIVEDIRECTORY (SETQ 
                                                                                        DIRECTORY 
                                                                                        BLIP))
                                                                    (T (SETQ DIRECTORY
                                                                        (OR (CADR X)
                                                                            BLIP])
                                               (RELATIVEDIRECTORY 

                                 (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified.  It really should act as a subdirectory in that case?  JDS")

                                                    (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                                           (OR (CADR X)
                                                                               BLIP))))
                                               (DIRECTORY [OR DIRECTORY
                                                              (COND
                                                                 (RELATIVEDIRECTORY (SETQ DIRECTORY 
                                                                                     BLIP))
                                                                 (T (SETQ DIRECTORY
                                                                     (OR (CADR X)
                                                                         BLIP])
                                               (ERROR "Illegal field in DIRECTORY slot" VAL)))
                                 (for X on VAL by (CDDR X)
                                    do (SELECTQ (CAR X)
                                               (HOST (OR DEVICE (SETQ DEVICE BLIP))
                                                     (OR DIRECTORY (SETQ DIRECTORY BLIP)))
                                               (DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
                                               NIL)))
                            (T (OR DIRECTORY (SETQ DIRECTORY BLIP])
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR VAL BLIP))))
                    (RELATIVEDIRECTORY 

                                 (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified.  It really should act as a subdirectory in that case?  JDS")

                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR VAL BLIP))))
                    (DEVICE (OR DEVICE (SETQ DEVICE (OR VAL BLIP))))
                    (NAME (OR NAME (SETQ NAME (OR VAL BLIP))))
                    (EXTENSION (OR EXTENSION (SETQ EXTENSION (OR VAL BLIP))))
                    (VERSION (OR VERSION (SETQ VERSION (OR VAL BLIP))))
                    (TEMPORARY (OR TEMPORARY (SETQ TEMPORARY (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (COND
               ((EQ HOST BLIP)
                (SETQ HOST NIL)))
            (COND
               ((EQ DEVICE BLIP)
                (SETQ DEVICE NIL)))
            (COND
               ((EQ DIRECTORY BLIP)
                (SETQ DIRECTORY NIL)))
            [COND
               ((EQ SUBDIRECTORY BLIP)
                (SETQ SUBDIRECTORY NIL))
               ((AND NIL SUBDIRECTORY)
                (COND
                   ((AND (NULL DIRECTORY)
                         (OR HOST DEVICE))
                    (SETQ DIRECTORY SUBDIRECTORY)
                    (SETQ SUBDIRECTORY NIL]
            (COND
               ((EQ RELATIVEDIRECTORY BLIP)
                (SETQ RELATIVEDIRECTORY NIL)))
            (RETURN (NCONC (AND HOST (LIST "{" HOST "}"))
                           [AND DEVICE (COND
                                          ((AND (SETQ TEMP (LASTCHPOS (CHARCODE %:)
                                                                  DEVICE 1))
                                                (EQ TEMP (NCHARS DEVICE)))
                                           (LIST DEVICE))
                                          (T (LIST DEVICE ":"]
                           [COND
                              (DIRECTORY (COND
                                            [[OR (STREQUAL DIRECTORY "<")
                                                 (AND (SETQ TEMP (LASTCHPOS (CHARCODE
                                                                                 (> /))
                                                                        DIRECTORY 1))
                                                      (EQ TEMP (NCHARS DIRECTORY]
                                             (COND
                                                ((EQMEMB (NTHCHARCODE DIRECTORY 1)
                                                        (CHARCODE (< /)))
                                                 (LIST DIRECTORY))
                                                (T (LIST (CL:FIRST \FILENAME.SYNTAX)
                                                         DIRECTORY]
                                            (T (LIST (CL:FIRST \FILENAME.SYNTAX)
                                                     DIRECTORY
                                                     (CL:SECOND \FILENAME.SYNTAX]
                           [COND
                              (RELATIVEDIRECTORY (COND
                                                    ((AND (SETQ TEMP (LASTCHPOS
                                                                      (CHARCODE (> /))
                                                                      RELATIVEDIRECTORY 1))
                                                          (EQ TEMP (NCHARS RELATIVEDIRECTORY)))
                                                     (LIST RELATIVEDIRECTORY))
                                                    (T (LIST RELATIVEDIRECTORY (CL:SECOND 
                                                                                     \FILENAME.SYNTAX
                                                                                      ]
                           [COND
                              (SUBDIRECTORY (LIST SUBDIRECTORY (CL:SECOND \FILENAME.SYNTAX]
                           (AND NAME (NEQ NAME BLIP)
                                (LIST NAME))
                           (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                    (AND VERSION (NEQ VERSION BLIP)))
                                (LIST (COND
                                         ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                             (CHARCODE %.)))
                                          BLIP)
                                         (T '%.))
                                      (OR EXTENSION BLIP)))
                           (AND VERSION (NEQ VERSION BLIP)
                                (LIST (CL:THIRD \FILENAME.SYNTAX)
                                      (COND
                                         ((FIXP VERSION)
                                          VERSION)
                                         (T (SELCHARQ (CHCON1 VERSION)
                                                 ((%. ! ;) 
                                                      (SUBSTRING VERSION 2 -1))
                                                 VERSION]

[PUTPROPS UNPACKFILE1 MACRO (OPENLAMBDA (NAM ST END)         (* lmm "22-APR-81 22:21")
                              (COND
                                 [(NOT ONEFIELDFLG)
                                  (SETQ VAL (CONS (COND
                                                     (PACKFLG (SUBATOM FILE ST END))
                                                     (T (OR (SUBSTRING FILE ST END)
                                                            "")))
                                                  (CONS NAM VAL]
                                 ((EQMEMB NAM ONEFIELDFLG)
                                  (RETURN (COND
                                             (PACKFLG (SUBATOM FILE ST END))
                                             (T (OR (SUBSTRING FILE ST END)
                                                    ""]
)
)

(RPAQQ \FILENAME.SYNTAX ("<" ">" ";"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \FILENAME.SYNTAX)
)



(* ; "saving and restoring system state")

(DEFINEQ

(LOGOUT
(LAMBDA (FAST) (* hdj "23-May-86 16:20") (\USEREVENT (QUOTE BEFORELOGOUT)) (COND ((OR (EQ FAST T) (\FLUSHVMOK? (QUOTE LOGOUT))) (* ; "Check that we have a vmem file before allowing LOGOUT") (\PROCESS.BEFORE.LOGOUT) (\DEVICEEVENT (QUOTE BEFORELOGOUT)) (\SETTOTALTIME) (* ; "update the total time that this sysout has been running.") (\LOGOUT0 FAST) (* ;; "Must re-establish the state of devices and of previously open files that might have been modified at the EXEC.") (\RESETKEYBOARD) (\DEVICEEVENT (QUOTE AFTERLOGOUT)) (\OPENLINEBUF) (\PROCESS.AFTER.EXIT (QUOTE AFTERLOGOUT)) (\USEREVENT (QUOTE AFTERLOGOUT)) (INTERPRET.REM.CM) NIL)))
)

(MAKESYS
  [LAMBDA (FILE NAME)
    (DECLARE (GLOBALVARS \MISCSTATS)
           (SPECVARS FILE NAME))                        (* ; "Edited 13-Oct-2020 22:51 by rmk:")
                                                             (* ; "Edited 28-Jul-88 18:16 by drc:")
    (\FLUSHVMOK? 'MAKESYS)
    (\USEREVENT 'BEFOREMAKESYS)
    (HERALD (CONCAT (OR NAME (CL:STRING-CAPITALIZE MAKESYSNAME))
                       " "
                       (SUBSTRING (SETQ MAKESYSDATE (DATE))
                              1 11)
                       " ..."))
    (\DEVICEEVENT 'BEFOREMAKESYS)

    (* ;; "RMK:  make sysout on a temp file, then rename it in order to get version numbers")

    (LET [(NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE))
                                    "-TEMP"]
         (COND
            ((NLISTP NEWFILE)                                (* ; 
                               "Coming back from doing the MAKESYS, so just set up to keep going.,")
             (\DEVICEEVENT 'AFTERDOMAKESYS)
             (\USEREVENT 'AFTERDOMAKESYS)
             (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP FILE)))
             FILE)
            (T                                               (* ; 
                                       "Coming back in the MAKESYS'd sysout, so restart the world.")
               (\DEVICEEVENT 'AFTERMAKESYS)
               (\PROCESS.AFTER.EXIT 'AFTERMAKESYS)
               (PRIN1 HERALDSTRING T)
               (\USEREVENT 'AFTERMAKESYS)
               (INTERPRET.REM.CM)                        (* ; 
                                                           "Run the commands in the file REM.CM")
               (RESET])

(SYSOUT
  [LAMBDA (FILE)                                        (* ; "Edited 14-Oct-2020 11:13 by rmk:")
                                                             (* hdj "29-Sep-86 12:14")
    (DECLARE (GLOBALVARS \MISCSTATS)
           (SPECVARS FILE))                                  (* ; 
                                           "FILE is special so that BEFORESYSOUTFORMS can alter it")
    (\FLUSHVMOK? 'SYSOUT)
    (\USEREVENT 'BEFORESYSOUT)
    (\DEVICEEVENT 'BEFORESYSOUT)

    (* ;; 
  "RMK:  Fix it so that sysouts are versioned.  Temp file goes to same place as eventual sysout.")

    (LET ((TOTALTIMESAVE (fetch TOTALTIME of \MISCSTATS))
          NEWFILE)                                           (* ; 
                    "update the total time field so that the run time in the sysout will be right.")
         (\SETTOTALTIME)
         (SETQ NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE))
                                        "-TEMP")))
         (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP FILE)))
         [COND
            ((NLISTP NEWFILE)

             (* ;; "Continuing in same sysout;  reset TOTALTIME in misc stats page to not include the time before the sysout.")

             (replace TOTALTIME of \MISCSTATS with TOTALTIMESAVE)
             (\DEVICEEVENT 'AFTERDOSYSOUT)
             (\USEREVENT 'AFTERDOSYSOUT))
            (T                                               (* ; "restarting")
               (\DEVICEEVENT 'AFTERSYSOUT)
               (\PROCESS.AFTER.EXIT 'AFTERSYSOUT)
               (INTERPRET.REM.CM)
               (\USEREVENT 'AFTERSYSOUT]
         FILE])

(SAVEVM
(LAMBDA (RELEASEFLG) (* hdj "23-May-86 16:20") (* ;; "Save the virtual memory.  This is similar to logging out, then back in, but is much faster, since it doesn't lose any pages.  Conceptually, this is like doing a sysout to Lisp.virtualmem") (\FLUSHVMOK? (QUOTE SAVEVM)) (\USEREVENT (QUOTE BEFORESAVEVM)) (\DEVICEEVENT (QUOTE BEFORESAVEVM)) (COND ((\FLUSHVM) (\RESETKEYBOARD) (* ; "Returns T when starting up fresh") (\DEVICEEVENT (QUOTE AFTERSAVEVM)) (\PROCESS.AFTER.EXIT (QUOTE AFTERSAVEVM)) (\USEREVENT (QUOTE AFTERSAVEVM)) T) (T (\DEVICEEVENT (QUOTE AFTERDOSAVEVM)) (\USEREVENT (QUOTE AFTERDOSAVEVM)))))
)

(HERALD
(LAMBDA (STR) (* wt%: " 2-MAY-79 15:38") (AND STR (SETQ HERALDSTRING STR)) HERALDSTRING))

(INTERPRET.REM.CM
  [LAMBDA (RETFLG)                                      (* ; "Edited 29-Jun-2017 15:36 by rmk:")
    (DECLARE (GLOBALVARS STARTUPFORM))

(* ;;; "Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote.  If it's a string, it will be unread,, else the form will be evaluated at the next prompt.  For use in INIT.LISP, among others.  If RETFLG is true, the expression read is simply returned")

    (PROG ([FILE (CAR (NLSETQ (OPENSTREAM '{DSK}REM.CM;1 'BOTH 'OLD]
           COM AUXFILE)
          (OR FILE (RETURN))
          [COND
             ([AND (IGREATERP (GETFILEINFO FILE 'LENGTH)
                          0)
                   (SELECTQ (SKIPSEPRS FILE T)
                       ((%( %") 
                            T)
                       NIL)
                   (SETQ COM (PROGN (SETFILEINFO FILE 'ENDOFSTREAMOP (FUNCTION ERROR!))
                                    (CAR (NLSETQ (READ FILE T]
              (COND
                 (RETFLG                                     (* ; "Save it to return"))
                 ((LISTP COM)                                (* ; "make it happen at next prompt")
                  (SETQ STARTUPFORM (LIST 'PROGN '(SETQ PROMPTCHARFORMS (DREMOVE STARTUPFORM 
                                                                               PROMPTCHARFORMS))
                                          (LIST 'PRINT (LIST 'LISPXEVAL (KWOTE COM))
                                                T T)))
                  (SETQ PROMPTCHARFORMS (CONS STARTUPFORM PROMPTCHARFORMS)))
                 (T                                          (* ; "Unread a string")
                                                             (* ; 
                                   "RMK: Replace CR and LF by space to avoid EOL convention issues")
                    (FOR I FROM 1 TO (NCHARS COM)
                       WHEN (FMEMB (NTHCHARCODE COM I)
                                       (CHARCODE (CR LF EOL))) DO (RPLCHARCODE COM I (CHARCODE
                                                                                          SPACE)))
                    (BKSYSBUF COM)))

              (* ;; "Eat up the command terminator")

              (WHILE (FMEMB (\PEEKBIN FILE T)
                                (CHARCODE (CR LF EOL ;))) DO (\BIN FILE))
              (COND
                 ((\EOFP FILE)                               (* ; 
                                                           "Nothing left, get rid of the file")
                  (CLOSEF FILE)
                  (DELFILE FILE)
                  (\SETEOFPTR FILE 0))
                 (T 
                    (* ;; "Need to rewrite REM.CM with remainder of text")

                    (SETQ AUXFILE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
                    (COPYBYTES FILE AUXFILE)
                    (SETFILEPTR FILE 0)
                    (COPYBYTES AUXFILE FILE 0 (GETFILEPTR AUXFILE))
                    (CLOSEF AUXFILE)
                    (\SETEOFPTR FILE (GETFILEPTR FILE))
                    (CLOSEF FILE]
          (RETURN (COND
                     (RETFLG COM)
                     (COM T])

(\USEREVENT
(LAMBDA (EVENT) (DECLARE (GLOBALVARS AROUNDEXITFNS)) (* bvm%: "16-Dec-83 15:27") (for FN in (SELECTQ EVENT ((BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM BEFOREMAKESYS) AROUNDEXITFNS) (REVERSE AROUNDEXITFNS)) do (APPLY* FN EVENT)))
)
)

(ADDTOVAR AROUNDEXITFNS )

(RPAQ? HERALDSTRING "")

(RPAQ? \USERNAME )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS)
)
(DEFINEQ

(USERNAME
(LAMBDA (FLG STRPTR PRESERVECASE) (* lmm "28-MAR-82 14:10") (* ; "On 10, USERNAME can take a user number as arg") (PROG (ADDR NAME) (SETQ NAME (COND (FLG NIL) ((NEQ 0 (SETQ ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage))) (GetBcplString (\ADDBASE (EMADDRESS 0) ADDR) (EQ STRPTR T))) (T \USERNAME))) (OR PRESERVECASE (NULL NAME) (SETQ NAME (U-CASE NAME))) (RETURN (COND ((NULL NAME) NIL) ((STRINGP STRPTR) (SUBSTRING NAME 1 -1 STRPTR)) (T NAME)))))
)

(SETUSERNAME
(LAMBDA (NAME) (* lmm "28-MAR-82 14:11") (* ; "Changed interpretation of UserName0") (COND (NAME (PROG ((ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage))) (RETURN (COND ((NEQ ADDR 0) (SetBcplString (\ADDBASE (EMADDRESS 0) ADDR) NAME) (SETQ USERNAME (USERNAME NIL T))) (T (SETQ \USERNAME (CONCAT NAME)))))))))
)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 

(FILESLOAD (LOADCOMP)
       FILEIO)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
)
(PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 
1991 1992 1920 2017 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2794 7673 (DELFILE 2804 . 2904) (FULLNAME 2906 . 3140) (INFILE 3142 . 3248) (INFILEP 
3250 . 3339) (IOFILE 3341 . 3438) (OPENFILE 3440 . 3840) (OPENSTREAM 3842 . 6967) (OUTFILE 6969 . 7078
) (OUTFILEP 7080 . 7170) (RENAMEFILE 7172 . 7412) (SIMPLE.FINDFILE 7414 . 7671)) (8045 17409 (
UNPACKFILENAME 8055 . 8204) (UNPACKFILENAME.STRING 8206 . 15792) (LASTCHPOS 15794 . 16079) (
\UPF.NEXTPOS 16081 . 16298) (\UPF.TEMPFILEP 16300 . 16732) (FILENAMEFIELD 16734 . 16971) (PACKFILENAME
 16973 . 17179) (PACKFILENAME.STRING 17181 . 17407)) (38426 46850 (LOGOUT 38436 . 39085) (MAKESYS 
39087 . 40854) (SYSOUT 40856 . 42599) (SAVEVM 42601 . 43223) (HERALD 43225 . 43326) (INTERPRET.REM.CM 
43328 . 46603) (\USEREVENT 46605 . 46848)) (47032 47847 (USERNAME 47042 . 47511) (SETUSERNAME 47513 . 
47845)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Feb-2021 15:32:34" {DSK}<home>larry>medley>sources>ADIR.;11 61717  

      changes to%:  (FNS INTERPRET.REM.CM)

      previous date%: "21-Feb-2021 21:49:20" {DSK}<home>larry>medley>sources>ADIR.;10)


(* ; "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1920, 2017, 2020, 2021 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT ADIRCOMS)

(RPAQQ ADIRCOMS
       [[COMS                                                (* ; "user-level i/o routines")
              (FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE OUTFILEP 
                   RENAMEFILE SIMPLE.FINDFILE)
              (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T))
              (P (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P 

                                       (* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM.  PATHNAMEP (and pathnames) get defined much later in the loadup.")

                                                 (MOVD? 'NILL 'CL:PATHNAMEP]
        (COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP 
                   FILENAMEFIELD PACKFILENAME PACKFILENAME.STRING)
              (DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY 
                                         PACKFILENAME.ASSEMBLE UNPACKFILE1))
              (VARS \FILENAME.SYNTAX)
              (GLOBALVARS \FILENAME.SYNTAX))
        (COMS                                                (* ; 
                                                           "saving and restoring system state")
              (FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT)
              (ADDVARS (AROUNDEXITFNS))
              (INITVARS (HERALDSTRING "")
                     (\USERNAME))
              (GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS)
              (FNS USERNAME SETUSERNAME))
        (LOCALVARS . T)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                                FILEIO))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA 
                                                                                  PACKFILENAME.STRING
                                                                                   PACKFILENAME])



(* ; "user-level i/o routines")

(DEFINEQ

(DELFILE
  [LAMBDA (FILE)                                         (* bvm%: "23-Oct-85 11:20")
    (AND FILE (NEQ FILE T)
         (\DELETEFILE FILE])

(FULLNAME
  [LAMBDA (X RECOG)                                      (* rmk%: "22-AUG-83 13:33")
    (COND
       ((type? STREAM X)
        (fetch (STREAM FULLNAME) of X))
       (T (SELECTQ RECOG
              (NIL (SETQQ RECOG OLD))
              ((OLD OLD/NEW NEW OLDEST))
              (\ILLEGAL.ARG RECOG))
          (\GETFILENAME X RECOG])

(INFILE
  [LAMBDA (FILE)                                         (* rmk%: " 3-OCT-79 14:23")
    (INPUT (OPENFILE FILE 'INPUT 'OLD])

(INFILEP
  [LAMBDA (FILE)                                         (* rmk%: " 9-OCT-79 22:39")
    (\GETFILENAME FILE 'OLD])

(IOFILE
  [LAMBDA (FILE)                                         (* rmk%: " 5-SEP-81 13:54")
    (OPENFILE FILE 'BOTH 'OLD])

(OPENFILE
  [LAMBDA (FILE ACCESS RECOG PARAMETERS OPTIONAL)        (* ; "Edited 23-May-91 19:12 by jds")
    (if MULTIPLE.STREAMS.PER.FILE.ALLOWED
        then (OPENSTREAM FILE ACCESS RECOG PARAMETERS OPTIONAL)
      else (fetch (STREAM FULLNAME) of (OPENSTREAM FILE ACCESS RECOG PARAMETERS 
                                                          OPTIONAL])

(OPENSTREAM
  [LAMBDA (FILE ACCESS RECOG PARAMETERS OBSOLETE)        (* hdj "28-Aug-86 14:50")
    (PROG (REC OLDSTREAM STREAM)
          (SELECTQ ACCESS
              ((INPUT OUTPUT BOTH APPEND))
              (\ILLEGAL.ARG ACCESS))
          (SETQ REC (SELECTQ RECOG
                        ((EXACT NEW OLD OLD/NEW OLDEST) 
                             RECOG)
                        (NIL (SELECTQ ACCESS
                                 (INPUT 'OLD)
                                 (OUTPUT 'NEW)
                                 'OLD/NEW))
                        (\ILLEGAL.ARG RECOG)))
          (if (OR (LISTP OBSOLETE)
                      (AND PARAMETERS (NLISTP PARAMETERS)))
              then 

                    (* ;; "used to have OPENFILE/OPENSTREAM with BYTESIZE and PARAMETERS.  Now it will take PARAMETERS, and generally ignore the BYTESIZE")

                    (SETQ PARAMETERS (APPEND (SELECTQ PARAMETERS
                                                 (7 '((TYPE TEXT)))
                                                 (8 '((TYPE BINARY)))
                                                 NIL)
                                            OBSOLETE)))
          (COND
             ((OR (EQ FILE T)
                  (NULL FILE))

              (* ;; "Handle T and NIL separately, cause they can return the terminal streams, for which the search isn't necessary and the \ADDOFD shouldn't be done.")

              (SETQ STREAM (\GETSTREAM FILE ACCESS))
              (\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS)
              (RETURN STREAM)))

     (* ;; "Explicitly test for PATHNAMEP, as PATHNAMEP will have a NILL def early in the loadup, and the tests in \CONVERT-PATHNAME won't break anything")

     (* ;; "Pavel changed a call to (PATHNAMEP FILE) into (TYPEP FILE `PATHNAME) because PATHNAMEP didn't have a NILL defn early in the loadup and TYPEP has an optimizer on it that compiles away the call to TYPEP which also has no defn early in the loadup.")

     (* ;; "Pavel also added the call to MKSTRING below as a temporary hack to get around the fact that the Interlisp string functions can't yet handle Common Lisp simple-strings.")

          (if (TYPEP FILE 'PATHNAME)
              then (SETQ FILE (\CONVERT-PATHNAME FILE)))

     (* ;; "We open the file before looking to see whether it is already open.  This guarantees that we acquire the opening rights at the time we lookup the name.  We then check to see if it is currently open in Lisp.  If it is, we return the previous stream, which has the file's current state.  ")

     (* ;; "There are still potential problems: First, an interrupt can happen while we are doing the search which causes the file to be deleted or re-opened beneath us, BEFORE it gets added to \OPENFILES.  Second, a network device might not allow multiple openings of the file, even by the same guy with the same mode.")

          (SETQ STREAM (\OPENFILE FILE ACCESS REC PARAMETERS))
          (COND
             [[AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED)
                   (SETQ OLDSTREAM (\SEARCHOPENFILES (fetch FULLNAME of STREAM]

              (* ;; "There is already a stream open on the file.  Check that there is no conflict.  Eventually all this registration belongs in the device, so that we can have multiple streams open per file")

              (COND
                 ((AND (EQ ACCESS 'INPUT)
                       (EQ (fetch ACCESS of OLDSTREAM)
                           'INPUT))                          (* ; 
    "Dispose of the newly-obtained stream, This might be a noop, but a network device (LEAF) cares")
                  (OR (EQ STREAM OLDSTREAM)
                      (\CLOSEFILE STREAM))
                  (\DO.PARAMS.AT.OPEN OLDSTREAM ACCESS PARAMETERS)
                                                             (* ; "Do parameters on the old stream")
                  (RETURN OLDSTREAM))
                 (T (LISPERROR "FILE WON'T OPEN" FILE]
             (T (AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED)
                     (\ADDOFD STREAM))                       (* ; 
                                                       "Parameters done on new stream by \OPENFILE")
                (RETURN STREAM])

(OUTFILE
  [LAMBDA (FILE)                                         (* rmk%: " 3-OCT-79 14:24")
    (OUTPUT (OPENFILE FILE 'OUTPUT 'NEW])

(OUTFILEP
  [LAMBDA (FILE)                                         (* rmk%: " 9-OCT-79 22:39")
    (\GETFILENAME FILE 'NEW])

(RENAMEFILE
  [LAMBDA (OLDFILE NEWFILE)                              (* hdj " 4-Sep-86 16:56")
    (SETQ OLDFILE (\CONVERT-PATHNAME OLDFILE))
    (SETQ NEWFILE (\CONVERT-PATHNAME NEWFILE))
    (AND OLDFILE NEWFILE (NEQ OLDFILE T)
         (NEQ NEWFILE T)
         (\RENAMEFILE OLDFILE NEWFILE])

(SIMPLE.FINDFILE
  [LAMBDA (FILE DUMMY DIRLST)                            (* bvm%: "23-Oct-85 11:22")
    (OR (for DIR in DIRLST when (SETQ $$VAL (INFILEP (PACKFILENAME.STRING
                                                                      'DIRECTORY DIR 'BODY FILE)))
           do (RETURN $$VAL))
        (AND (NOT (MEMB NIL DIRLST))
             (INFILEP FILE])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ MULTIPLE.STREAMS.PER.FILE.ALLOWED T)


(CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T))
)

(MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T)
(DECLARE%: DONTEVAL@LOAD DOCOPY 


(* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM.  PATHNAMEP (and pathnames) get defined much later in the loadup.")


(MOVD? 'NILL 'CL:PATHNAMEP)
)
(DEFINEQ

(UNPACKFILENAME
  [LAMBDA (FILE ONEFIELDFLG OSTYPE)                      (* ; "Edited  6-Jan-88 13:13 by bvm:")
    (UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T])

(UNPACKFILENAME.STRING
  [LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 30-Mar-90 22:37 by nm")

(* ;;; "Given a string or atom representation of a file name, unpack it into its component parts")

    (PROG ((POS 1)
           (LEN (NCHARS FILE))
           TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI)
          (COND
             ((NULL FILE)
              (RETURN NIL))
             ((OR (LITATOM FILE)
                  (STRINGP FILE)
                  (NUMBERP FILE)))
             ((TYPEP FILE 'PATHNAME)
              (RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG)))
             [(STREAMP FILE)                                 (* ; 
                                               "For streams, use full name.  If anonymous, fake it")
              (SETQ FILE (OR (ffetch FULLFILENAME of FILE)
                             (RETURN (COND
                                        (ONEFIELDFLG (AND (EQ ONEFIELDFLG 'NAME)
                                                          FILE))
                                        (T (LIST 'NAME FILE]
             (T (\ILLEGAL.ARG FILE)))
          (COND
             ((SELCHARQ (NTHCHARCODE FILE 1)
                   ({                                        (* ; "normal use in Interlisp-D")
                      (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE })
                                                 FILE 2)
                                          0))))
                   (%[                                       (* ; 
                                                  "some Xerox and Arpanet systems use '[' for host")
                       (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
                                                  FILE 2)
                                           0))))
                   (%(                                       (* ; 
                                                "this is the 'proposed standard' for Xerox servers")
                       (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
                                                  FILE 2)
                                           0))))
                   NIL)
              (UNPACKFILE1 'HOST 2 TEM)
              [COND
                 ((EQ TEM -1)                                (* ; 
    "Started with the host field delimiter, but there was no corresponding terminating delimiter .")
                                                             (* ; 
                                           "I'm not sure why the name is dealt with the host name.")
                  (RETURN (DREVERSE VAL]
              (SETQ POS (IPLUS TEM 2))
              [if (EQ OSTYPE T)
                  then                                   (* ; 
                                                           "Use actual host to determine os type")
                        (SETQ OSTYPE (GETHOSTINFO (CAR VAL)
                                            'OSTYPE]
              (SETQ HOSTP T)))
          (COND
             ((SETQ TEM (LASTCHPOS (CHARCODE %:)
                               FILE POS))                    (* ; 
                                 "all device returned have DEVICE.END on it so that NIL: will work")
              (UNPACKFILE1 'DEVICE POS (if CLFLG
                                           then (SUB1 TEM)
                                         else TEM))
              (SETQ POS (ADD1 TEM))
              (SETQ HOSTP T)))
          (COND
             ((EQ DIRFLG 'RETURN)                            (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter.  If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention.  In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.")
              (LET ((TYPE 'DIRECTORY)
                    (START (SELCHARQ (NTHCHARCODE FILE POS)
                                (NIL                         (* ; "just host, return")
                                     (RETURN (DREVERSE VAL)))
                                ((/ <)                       (* ; 
                                                    "Started with the initial directory delimiter.")
                                     (ADD1 POS))
                                POS))
                    END)
                   (SETQ END (SELCHARQ (NTHCHARCODE FILE -1)
                                  ((/ >) 
                                       [COND
                                          ((EQ START POS)    (* ; 
                                                         "Didn't start with a directory delimiter,")
                                           (COND
                                              ((NOT HOSTP)   (* ; "%"Incomplete file names%" case defined in IRM.  This is a subdirectory of the current connected directory")
                                               (SETQ TYPE 'SUBDIRECTORY))
                                              (T             (* ; "True %"relative pathname%".  The way to deal with it is dependent on the device on which HOST is implemented.")
                                                 (SETQ TYPE 'RELATIVEDIRECTORY]
                                       (COND
                                          ((EQ LEN POS)      (* ; 
                                       "Only the initial directory is specified (i.e. %"{DSK}/%").")
                                           (SETQ START POS)
                                           -1)
                                          (T -2)))
                                  (PROGN [COND
                                            [(EQ START POS)  (* ; 
                                            "Both of the initial and trail delimiters are omitted.")
                                             (COND
                                                ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM.  This is a subdirectory of the current connected directory")
                                                 (SETQ TYPE 'SUBDIRECTORY))
                                                (T           (* ; "True %"relative pathname%".  The way to deal with it is dependent on the device on which HOST is implemented.")
                                                   (SETQ TYPE 'RELATIVEDIRECTORY]
                                            (T (COND
                                                  ((EQ LEN POS)
                                                             (* ; 
                                       "Only the initial directory is specified (i.e. %"{DSK}<%").")
                                                   (SETQ START POS]
                                         -1)))
                   (UNPACKFILE1.DIRECTORY TYPE START END))
              (RETURN (DREVERSE VAL)))
             ((SELCHARQ (NTHCHARCODE FILE POS)
                   (/                                        (* ; 
                                                "unix and the 'xerox standard' use / for delimiter")
                                                             (* ; 
                       "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.")
                      (SETQ TEM (LASTCHPOS (CHARCODE (/ >))
                                       FILE
                                       (ADD1 POS)))
                      T)
                   ((< >)                                    (* ; 
             "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>.  Jericho uses >>")
                                                             (* ; 
                       "In the case of the {DSK}<FOO/BAR, FOO should be dealt with as a directory.")
                        (SETQ TEM (LASTCHPOS (CHARCODE (> /))
                                         FILE
                                         (ADD1 POS)))
                        T)
                   NIL)

              (* ;; "allow {DSK}/etc   to be a directory specification.")

              (if TEM
                  then (UNPACKFILE1.DIRECTORY 'DIRECTORY (ADD1 POS)
                                  (SUB1 TEM))
                        (SETQ POS (ADD1 TEM))
                else 

                      (* ;; "{DSK}/foo: the directory is /, the name is foo")

                      (UNPACKFILE1.DIRECTORY 'DIRECTORY POS POS)
                      (SETQ POS (ADD1 POS)))
              (SETQ HOSTP T))
             ((SETQ TEM (LASTCHPOS (CHARCODE (/ >))
                               FILE POS))                    (* ; " {eris}abc>  relative")

              (* ;; 
        " This is the true %"relative pathname%".  Returns RELATIVEDIRECTORY instead of DIRECTORY.")

              [COND
                 ((NOT HOSTP)                                (* ; "%"Incomplete file names%" case.")
                  (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
                                             then 'DIRECTORY
                                           else 'SUBDIRECTORY)
                         POS
                         (SUB1 TEM)))
                 (T                                          (* ; "True %"relative pathname%".")
                    (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG 'FIELD)
                                               then 'DIRECTORY
                                             else 'RELATIVEDIRECTORY)
                           POS
                           (SUB1 TEM]
              (SETQ POS (ADD1 TEM))
              (SETQ HOSTP T)))
          (OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
              (RETURN (DREVERSE VAL)))
          (if (EQ OSTYPE T)
              then                                       (* ; 
                                        "There wasn't a host field in the name, so we have no clue")
                    (SETQ OSTYPE NIL))
      NAMELP
          

     (* ;; "At this point, CODE is the TEM'th char of file name.  POS is the first character of the field we are currently working on.")

          (SELCHARQ CODE
               (%.                                           (* ; 
                          "Note position for later--we only want to deal with the last set of dots")
                   (if BEYONDNAME
                       then                              (* ; 
                                                 "no longer of interest (probably a bad name, too)")
                     elseif FIRSTDOT
                       then                              (* ; "We're recording the second dot")
                             (if SECONDDOT
                                 then                    (* ; 
                                                           "Note only the two most recent dots")
                                       (SETQ FIRSTDOT SECONDDOT))
                             (SETQ SECONDDOT TEM)
                     else (SETQ FIRSTDOT TEM)))
               ((! ; NIL)                                    (* ; 
                             "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now")
                    (if (SELCHARQ CODE
                                 (!                          (* ; 
               "! is only a delimiter on IFS, so ignore it if we know the ostype is something else")
                                    (AND OSTYPE (NEQ OSTYPE 'IFS)))
                                 (;                          (* ; "If we've already parsed the extension, then we have a semi in the middle of the version.  Skip it unless it's ;T or ;S")
                                    [AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM])
                                 NIL)
                        then (GO NEXTCHAR))
                    (if FIRSTDOT
                        then                             (* ; 
                                                        "Have a name and/or extension to parse now")
                        (if
                         [AND SECONDDOT
                              (NOT (if OSTYPE
                                       then              (* ; 
                                      "Known OS type must be Tops20 for second dot to mean version")
                                             (EQ OSTYPE 'TOPS20)
                                     else                (* ; 
                                "Unknown OS type, so check that %"version%" is numeric or wildcard")
                                           (AND [for I from (ADD1 SECONDDOT)
                                                   to (SUB1 TEM) bind CH
                                                   always (OR (DIGITCHARP (SETQ CH
                                                                               (NTHCHARCODE FILE I)))
                                                                  (EQ CH (CHARCODE *]
                                                (SELCHARQ CODE
                                                     (NIL    (* ; "end of file name, ok")
                                                          T)
                                                     (;      (* ; 
                                              "This semi-colon better not be introducing a version")
                                                        (\UPF.TEMPFILEP FILE (ADD1 TEM)))
                                                     NIL]
                            then                         (* ; 
                                                           "Second dot is not intoducing a version")
                                  (SETQ FIRSTDOT SECONDDOT)
                                  (SETQ SECONDDOT NIL))
                        (UNPACKFILE1 'NAME POS (SUB1 FIRSTDOT))
                        (SETQ POS (ADD1 (if SECONDDOT
                                            then (UNPACKFILE1 'EXTENSION (ADD1 FIRSTDOT)
                                                            (SUB1 SECONDDOT))
                                                  (SETQ BEYONDEXT T)
                                                  SECONDDOT
                                          else FIRSTDOT)))
                        (SETQ BEYONDNAME T)
                        (SETQ FIRSTDOT NIL))
                    (UNPACKFILE1 (COND
                                    ((NOT BEYONDNAME)
                                     (SETQQ BEYONDNAME NAME))
                                    ((NOT BEYONDEXT)
                                     'EXTENSION)
                                    ((AND (EQ BEYONDEXT (CHARCODE ";"))
                                          (\UPF.TEMPFILEP FILE POS)))
                                    (T                       (* ; 
                                                           "Everything after the semi was version")
                                       'VERSION))
                           POS
                           (SUB1 TEM))
                    (if (NULL CODE)
                        then                             (* ; "End of string")
                              (RETURN (DREVERSE VAL)))
                    (SETQ BEYONDEXT CODE)                    (* ; 
                                                  "Note the character that terminated the name/ext")
                    (SETQ POS (ADD1 TEM)))
               (%'                                           (* ; "Quoter")
                   (add TEM 1))
               NIL)
      NEXTCHAR
          (SETQ CODE (NTHCHARCODE FILE (add TEM 1)))
          (GO NAMELP])

(LASTCHPOS
  [LAMBDA (CH STR START)                              (* ; "Edited 17-May-88 13:43 by MASINTER")
    (PROG (RESULT NC)
          (OR START (SETQ START 1))
          (while (SETQ NC (NTHCHARCODE STR START)) do (COND
                                                                 ((EQMEMB NC CH)
                                                                  (SETQ RESULT START))
                                                                 ((EQ NC (CHARCODE %'))
                                                                  (add START 1)))
                                                             (add START 1))
          (RETURN RESULT])

(\UPF.NEXTPOS
  [LAMBDA (CHAR STRING POS)                              (* lmm " 5-Oct-84 18:41")
    (bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND
                                                                          ((EQMEMB NCH CHAR)
                                                                           (RETURN POS))
                                                                          ((EQ NCH (CHARCODE %'))
                                                                           (add POS 1)))
                                                                      (add POS 1])

(\UPF.TEMPFILEP
  [LAMBDA (FILENAME START)                               (* ; "Edited  6-Jan-88 13:12 by bvm:")

    (* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START.  Returns the appropriate field name if so.  Not sure we should parse this junk any more, but this at least localizes it.")

    (SELCHARQ (NTHCHARCODE FILENAME START)
         ((T S)                                              (* ; "Funny temp stuff")
              (AND (EQ START (NCHARS FILENAME))
                   'TEMPORARY))
         NIL])

(FILENAMEFIELD
  [LAMBDA (FILE FIELDNAME)                               (* ; "Edited  6-Mar-90 19:38 by nm")
    (UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME
                                        ((VERSION GENERATION) 
                                             'VERSION)
                                        ((DEVICE STRUCTURE) 
                                             'DEVICE)
                                        FIELDNAME)
           'FIELD NIL T])

(PACKFILENAME
  [LAMBDA N                                              (* bvm%: " 5-Jul-85 15:40")
    (COND
       ((AND (EQ N 1)
             (LISTP (ARG N 1)))                              (* ; "spread argument list")
        (APPLY (FUNCTION PACKFILENAME)
               (ARG N 1)))
       (T (PACK (PACKFILENAME.ASSEMBLE])

(PACKFILENAME.STRING
  [LAMBDA N                                              (* bvm%: " 5-Jul-85 15:41")
    (COND
       ((AND (EQ N 1)
             (LISTP (ARG N 1)))                              (* ; "spread argument list")
        (APPLY (FUNCTION PACKFILENAME.STRING)
               (ARG N 1)))
       (T (CONCATLIST (PACKFILENAME.ASSEMBLE])
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS CANONICAL.DIRECTORY MACRO
          [OPENLAMBDA (SRCSTRING)
            (AND
             SRCSTRING
             (LET
              ((LEN (NCHARS SRCSTRING)))
              (COND
                 ((EQ LEN 1)
                  (if (STREQUAL SRCSTRING "/")
                      then "<"
                    else SRCSTRING))
                 (T
                  (LET*
                   ((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING))
                    (DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T)))
                    (DSTBASE (ffetch (STRINGP BASE) of DSTSTRING))
                    (DSTPOS 0)
                    (NEXTPOS -1))
                   (if (NOT FATP)
                       then
                       [for SRCPOS from 1 to LEN bind CODE
                          first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
                                                      (CHARCODE (< / >)))
                                       do (add SRCPOS 1))
                                (if (> SRCPOS LEN)
                                    then (RETURN "<"))
                          do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
                                      ((> /) 
                                           (if (> DSTPOS NEXTPOS)
                                               then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >))
                                                     (SETQ NEXTPOS (add DSTPOS 1))))
                                      (%' (\PUTBASETHIN DSTBASE DSTPOS CODE)
                                          (add DSTPOS 1)
                                          (if (NEQ SRCPOS LEN)
                                              then (\PUTBASETHIN DSTBASE DSTPOS
                                                              (NTHCHARCODE SRCSTRING (add SRCPOS
                                                                                            1)))
                                                    (add DSTPOS 1)))
                                      (PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE)
                                             (add DSTPOS 1)))
                          finally (RETURN (if (EQ DSTPOS LEN)
                                                  then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
                                                                          (CHARCODE (> /)))
                                                               then (SUBSTRING DSTSTRING 1 -2)
                                                             else DSTSTRING)
                                                elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
                                                                  (CHARCODE (> /)))
                                                  then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
                                                else (SUBSTRING DSTSTRING 1 DSTPOS]
                     else
                     (for SRCPOS from 1 to LEN bind CODE
                        first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS)
                                                    (CHARCODE (< / >))) do (add SRCPOS 1))
                        do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS))
                                    ((> /) 
                                         (if (> DSTPOS NEXTPOS)
                                             then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >))
                                                   (SETQ NEXTPOS (add DSTPOS 1))))
                                    (%' (\PUTBASEFAT DSTBASE DSTPOS CODE)
                                        (add DSTPOS 1)
                                        (if (NEQ SRCPOS LEN)
                                            then (\PUTBASEFAT DSTBASE DSTPOS
                                                            (NTHCHARCODE SRCSTRING (add SRCPOS 1)
                                                                   ))
                                                  (add DSTPOS 1)))
                                    (PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE)
                                           (add DSTPOS 1)))
                        finally (RETURN (if (EQ DSTPOS LEN)
                                                then (if (EQMEMB (NTHCHARCODE DSTSTRING -1)
                                                                        (CHARCODE (> /)))
                                                             then (SUBSTRING DSTSTRING 1 -2)
                                                           else DSTSTRING)
                                              elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS)
                                                                (CHARCODE (> /)))
                                                then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS))
                                              else (SUBSTRING DSTSTRING 1 DSTPOS])

(PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END)
                                                (LET* ((OLDDIR (SUBSTRING FILE ST END))
                                                       (NEWDIR (CANONICAL.DIRECTORY OLDDIR)))
                                                      (COND
                                                         [(NOT ONEFIELDFLG)
                                                          (SETQ VAL
                                                           (CONS (COND
                                                                    (PACKFLG (AND NEWDIR (MKATOM
                                                                                          NEWDIR)))
                                                                    (T (OR NEWDIR "")))
                                                                 (CONS NAM VAL]
                                                         ((EQMEMB NAM ONEFIELDFLG)
                                                          (RETURN (COND
                                                                     (PACKFLG (AND NEWDIR
                                                                                   (MKATOM NEWDIR)))
                                                                     (T (OR NEWDIR ""])

(PUTPROPS PACKFILENAME.ASSEMBLE MACRO
          [NIL
           (PROG ((BLIP "")
                  (I 1)
                  HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY NAME EXTENSION 
                  VERSION TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
                 (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY NAME EXTENSION 
                                     VERSION TEMPORARY PROTECTION ACCOUNT))
             LP  (COND
                    ((<= I N)

                     (* ;; "Grab the next field-name / value pair and fold it into the filename:")

                     (COND
                        ((LISTP (SETQ VAR (ARG N I)))
                         (SETQ VAL (CDR VAR))
                         (SETQ VAR (CAR VAR)))
                        ((<= (SETQ I (ADD1 I))
                             N)
                         (SETQ VAL (ARG N I)))
                        (T (SETQ VAL)))
                     (OR (STRINGP VAL)
                         (ATOM VAL)
                         (EQ VAR 'BODY)
                         (\ILLEGAL.ARG VAL))
                     (SELECTQ VAR
                         (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                                  ((LISTP VAL)
                                                                   (PACKFILENAME.STRING VAL))
                                                                  (T VAL))
                                           NIL
                                           'OK)
                                    [FUNCTION (LAMBDA (X)
                                                (SELECTQ (CAR X)
                                                    (HOST (OR HOST (SETQ HOST (OR (CADR X)
                                                                                  BLIP))))
                                                    (DEVICE (OR DEVICE (SETQ DEVICE
                                                                        (OR (CADR X)
                                                                            BLIP))))
                                                    (DIRECTORY [OR DIRECTORY
                                                                   (COND
                                                                      (RELATIVEDIRECTORY (SETQ 
                                                                                          DIRECTORY 
                                                                                          BLIP))
                                                                      (T (SETQ DIRECTORY
                                                                          (OR (CADR X)
                                                                              BLIP])
                                                    (SUBDIRECTORY (OR SUBDIRECTORY
                                                                      (SETQ SUBDIRECTORY
                                                                       (OR (CADR X)
                                                                           BLIP))))
                                                    (RELATIVEDIRECTORY 
                                                         [OR RELATIVEDIRECTORY
                                                             (COND
                                                                (DIRECTORY (SETQ RELATIVEDIRECTORY 
                                                                            BLIP))
                                                                (T (SETQ RELATIVEDIRECTORY
                                                                    (OR (CADR X)
                                                                        BLIP])
                                                    (NAME (OR NAME (SETQ NAME (OR (CADR X)
                                                                                  BLIP))))
                                                    (EXTENSION (OR EXTENSION (SETQ EXTENSION
                                                                              (OR (CADR X)
                                                                                  BLIP))))
                                                    (VERSION (OR VERSION (SETQ VERSION
                                                                          (OR (CADR X)
                                                                              BLIP))))
                                                    (SHOULDNT]
                                    (FUNCTION CDDR)))
                         (HOST [OR HOST (SETQ HOST (COND
                                                      (VAL (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL))
                                                      (T BLIP])
                         ((PATHNAME DIRECTORY) 
                              [COND
                                 (VAL
                                  (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL
                                                                     'RETURN))
                                     by (CDDR X)
                                     do (SELECTQ (CAR X)
                                                (HOST [COND
                                                         ((NOT HOST)
                                                          (SETQ HOST (OR (CADR X)
                                                                         BLIP])
                                                (DEVICE [COND
                                                           ((NOT DEVICE)
                                                            (SETQ DEVICE (OR (CADR X)
                                                                             BLIP])
                                                (SUBDIRECTORY [OR DIRECTORY
                                                                  (COND
                                                                     (RELATIVEDIRECTORY (SETQ 
                                                                                         DIRECTORY 
                                                                                         BLIP))
                                                                     (T (SETQ DIRECTORY
                                                                         (OR (CADR X)
                                                                             BLIP])
                                                (RELATIVEDIRECTORY 

                                 (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified.  It really should act as a subdirectory in that case?  JDS")

                                                     (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                                            (OR (CADR X)
                                                                                BLIP))))
                                                (DIRECTORY [OR DIRECTORY
                                                               (COND
                                                                  (RELATIVEDIRECTORY (SETQ DIRECTORY
                                                                                      BLIP))
                                                                  (T (SETQ DIRECTORY
                                                                      (OR (CADR X)
                                                                          BLIP])
                                                (ERROR "Illegal field in DIRECTORY slot" VAL)))
                                  (for X on VAL by (CDDR X)
                                     do (SELECTQ (CAR X)
                                                (HOST (OR DEVICE (SETQ DEVICE BLIP))
                                                      (OR DIRECTORY (SETQ DIRECTORY BLIP)))
                                                (DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
                                                NIL)))
                                 (T (OR DIRECTORY (SETQ DIRECTORY BLIP])
                         (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR VAL BLIP))))
                         (RELATIVEDIRECTORY 

                                 (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified.  It really should act as a subdirectory in that case?  JDS")

                              (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR VAL BLIP))))
                         (DEVICE (OR DEVICE (SETQ DEVICE (OR VAL BLIP))))
                         (NAME (OR NAME (SETQ NAME (OR VAL BLIP))))
                         (EXTENSION (OR EXTENSION (SETQ EXTENSION (OR VAL BLIP))))
                         (VERSION (OR VERSION (SETQ VERSION (OR VAL BLIP))))
                         (TEMPORARY (OR TEMPORARY (SETQ TEMPORARY (OR VAL BLIP))))
                         (\ILLEGAL.ARG VAR))
                     (SETQ I (ADD1 I))
                     (GO LP)))
                 (COND
                    ((EQ HOST BLIP)
                     (SETQ HOST NIL)))
                 (COND
                    ((EQ DEVICE BLIP)
                     (SETQ DEVICE NIL)))
                 (COND
                    ((EQ DIRECTORY BLIP)
                     (SETQ DIRECTORY NIL)))
                 [COND
                    ((EQ SUBDIRECTORY BLIP)
                     (SETQ SUBDIRECTORY NIL))
                    ((AND NIL SUBDIRECTORY)
                     (COND
                        ((AND (NULL DIRECTORY)
                              (OR HOST DEVICE))
                         (SETQ DIRECTORY SUBDIRECTORY)
                         (SETQ SUBDIRECTORY NIL]
                 (COND
                    ((EQ RELATIVEDIRECTORY BLIP)
                     (SETQ RELATIVEDIRECTORY NIL)))
                 (RETURN (NCONC (AND HOST (LIST "{" HOST "}"))
                                [AND DEVICE (COND
                                               ((AND (SETQ TEMP (LASTCHPOS (CHARCODE %:)
                                                                       DEVICE 1))
                                                     (EQ TEMP (NCHARS DEVICE)))
                                                (LIST DEVICE))
                                               (T (LIST DEVICE ":"]
                                [COND
                                   (DIRECTORY (COND
                                                 [[OR (STREQUAL DIRECTORY "<")
                                                      (AND (SETQ TEMP (LASTCHPOS
                                                                       (CHARCODE (> /))
                                                                       DIRECTORY 1))
                                                           (EQ TEMP (NCHARS DIRECTORY]
                                                  (COND
                                                     ((EQMEMB (NTHCHARCODE DIRECTORY 1)
                                                             (CHARCODE (< /)))
                                                      (LIST DIRECTORY))
                                                     (T (LIST (CL:FIRST \FILENAME.SYNTAX)
                                                              DIRECTORY]
                                                 (T (LIST (CL:FIRST \FILENAME.SYNTAX)
                                                          DIRECTORY
                                                          (CL:SECOND \FILENAME.SYNTAX]
                                [COND
                                   (RELATIVEDIRECTORY (COND
                                                         ((AND (SETQ TEMP (LASTCHPOS
                                                                           (CHARCODE (> /))
                                                                           RELATIVEDIRECTORY 1))
                                                               (EQ TEMP (NCHARS RELATIVEDIRECTORY)))
                                                          (LIST RELATIVEDIRECTORY))
                                                         (T (LIST RELATIVEDIRECTORY (CL:SECOND 
                                                                                     \FILENAME.SYNTAX
                                                                                           ]
                                [COND
                                   (SUBDIRECTORY (LIST SUBDIRECTORY (CL:SECOND \FILENAME.SYNTAX]
                                (AND NAME (NEQ NAME BLIP)
                                     (LIST NAME))
                                (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                         (AND VERSION (NEQ VERSION BLIP)))
                                     (LIST (COND
                                              ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                                  (CHARCODE %.)))
                                               BLIP)
                                              (T '%.))
                                           (OR EXTENSION BLIP)))
                                (AND VERSION (NEQ VERSION BLIP)
                                     (LIST (CL:THIRD \FILENAME.SYNTAX)
                                           (COND
                                              ((FIXP VERSION)
                                               VERSION)
                                              (T (SELCHARQ (CHCON1 VERSION)
                                                      ((%. ! ;) 
                                                           (SUBSTRING VERSION 2 -1))
                                                      VERSION])

(PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END)
                                                             (* lmm "22-APR-81 22:21")
                                      (COND
                                         [(NOT ONEFIELDFLG)
                                          (SETQ VAL (CONS (COND
                                                             (PACKFLG (SUBATOM FILE ST END))
                                                             (T (OR (SUBSTRING FILE ST END)
                                                                    "")))
                                                          (CONS NAM VAL]
                                         ((EQMEMB NAM ONEFIELDFLG)
                                          (RETURN (COND
                                                     (PACKFLG (SUBATOM FILE ST END))
                                                     (T (OR (SUBSTRING FILE ST END)
                                                            ""])
)
)

(RPAQQ \FILENAME.SYNTAX ("<" ">" ";"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \FILENAME.SYNTAX)
)



(* ; "saving and restoring system state")

(DEFINEQ

(LOGOUT
  [LAMBDA (FAST)                                         (* hdj "23-May-86 16:20")
    (\USEREVENT 'BEFORELOGOUT)
    (COND
       ((OR (EQ FAST T)
            (\FLUSHVMOK? 'LOGOUT))                           (* ; 
                                            "Check that we have a vmem file before allowing LOGOUT")
        (\PROCESS.BEFORE.LOGOUT)
        (\DEVICEEVENT 'BEFORELOGOUT)
        (\SETTOTALTIME)                                      (* ; 
                                         "update the total time that this sysout has been running.")
        (\LOGOUT0 FAST)

        (* ;; "Must re-establish the state of devices and of previously open files that might have been modified at the EXEC.")

        (\RESETKEYBOARD)
        (\DEVICEEVENT 'AFTERLOGOUT)
        (\OPENLINEBUF)
        (\PROCESS.AFTER.EXIT 'AFTERLOGOUT)
        (\USEREVENT 'AFTERLOGOUT)
        (INTERPRET.REM.CM)
        NIL])

(MAKESYS
  [LAMBDA (FILE NAME)
    (DECLARE (GLOBALVARS \MISCSTATS)
           (SPECVARS FILE NAME))                        (* ; "Edited 13-Oct-2020 22:51 by rmk:")
                                                             (* ; "Edited 28-Jul-88 18:16 by drc:")
    (\FLUSHVMOK? 'MAKESYS)
    (\USEREVENT 'BEFOREMAKESYS)
    (HERALD (CONCAT (OR NAME (CL:STRING-CAPITALIZE MAKESYSNAME))
                       " "
                       (SUBSTRING (SETQ MAKESYSDATE (DATE))
                              1 11)
                       " ..."))
    (\DEVICEEVENT 'BEFOREMAKESYS)

    (* ;; "RMK:  make sysout on a temp file, then rename it in order to get version numbers")

    (LET [(NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE))
                                    "-TEMP"]
         (COND
            ((NLISTP NEWFILE)                                (* ; 
                               "Coming back from doing the MAKESYS, so just set up to keep going.,")
             (\DEVICEEVENT 'AFTERDOMAKESYS)
             (\USEREVENT 'AFTERDOMAKESYS)
             (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP FILE)))
             FILE)
            (T                                               (* ; 
                                       "Coming back in the MAKESYS'd sysout, so restart the world.")
               (\DEVICEEVENT 'AFTERMAKESYS)
               (\PROCESS.AFTER.EXIT 'AFTERMAKESYS)
               (PRIN1 HERALDSTRING T)
               (\USEREVENT 'AFTERMAKESYS)
               (INTERPRET.REM.CM)                        (* ; 
                                                           "Run the commands in the file REM.CM")
               (RESET])

(SYSOUT
  [LAMBDA (FILE)                                        (* ; "Edited 14-Oct-2020 11:13 by rmk:")
                                                             (* hdj "29-Sep-86 12:14")
    (DECLARE (GLOBALVARS \MISCSTATS)
           (SPECVARS FILE))                                  (* ; 
                                           "FILE is special so that BEFORESYSOUTFORMS can alter it")
    (\FLUSHVMOK? 'SYSOUT)
    (\USEREVENT 'BEFORESYSOUT)
    (\DEVICEEVENT 'BEFORESYSOUT)

    (* ;; 
  "RMK:  Fix it so that sysouts are versioned.  Temp file goes to same place as eventual sysout.")

    (LET ((TOTALTIMESAVE (fetch TOTALTIME of \MISCSTATS))
          NEWFILE)                                           (* ; 
                    "update the total time field so that the run time in the sysout will be right.")
         (\SETTOTALTIME)
         (SETQ NEWFILE (\COPYSYS (CONCAT (PACKFILENAME 'VERSION NIL 'BODY (OUTFILEP FILE))
                                        "-TEMP")))
         (RENAMEFILE NEWFILE (SETQ FILE (OUTFILEP FILE)))
         [COND
            ((NLISTP NEWFILE)

             (* ;; "Continuing in same sysout;  reset TOTALTIME in misc stats page to not include the time before the sysout.")

             (replace TOTALTIME of \MISCSTATS with TOTALTIMESAVE)
             (\DEVICEEVENT 'AFTERDOSYSOUT)
             (\USEREVENT 'AFTERDOSYSOUT))
            (T                                               (* ; "restarting")
               (\DEVICEEVENT 'AFTERSYSOUT)
               (\PROCESS.AFTER.EXIT 'AFTERSYSOUT)
               (INTERPRET.REM.CM)
               (\USEREVENT 'AFTERSYSOUT]
         FILE])

(SAVEVM
  [LAMBDA (RELEASEFLG)                                   (* hdj "23-May-86 16:20")

    (* ;; "Save the virtual memory.  This is similar to logging out, then back in, but is much faster, since it doesn't lose any pages.  Conceptually, this is like doing a sysout to Lisp.virtualmem")

    (\FLUSHVMOK? 'SAVEVM)
    (\USEREVENT 'BEFORESAVEVM)
    (\DEVICEEVENT 'BEFORESAVEVM)
    (COND
       ((\FLUSHVM)
        (\RESETKEYBOARD)                                     (* ; 
                                                           "Returns T when starting up fresh")
        (\DEVICEEVENT 'AFTERSAVEVM)
        (\PROCESS.AFTER.EXIT 'AFTERSAVEVM)
        (\USEREVENT 'AFTERSAVEVM)
        T)
       (T (\DEVICEEVENT 'AFTERDOSAVEVM)
          (\USEREVENT 'AFTERDOSAVEVM])

(HERALD
  [LAMBDA (STR)                                          (* wt%: " 2-MAY-79 15:38")
    (AND STR (SETQ HERALDSTRING STR))
    HERALDSTRING])

(INTERPRET.REM.CM
  [LAMBDA (RETFLG)                                     (* ; "Edited 22-Feb-2021 15:31 by larry")
    (DECLARE (GLOBALVARS STARTUPFORM))

(* ;;; "Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote.  If it's a string, it will be unread,, else the form will be evaluated at the next prompt.  For use in INIT.LISP, among others.  If RETFLG is true, the expression read is simply returned")

    (PROG ((FILE (UNIX-GETENV "LDEINIT"))
           COM)
          (OR FILE (RETURN))
          (SETQ FILE (OPENSTREAM FILE 'INPUT))
          [COND
             ([AND (IGREATERP (GETFILEINFO FILE 'LENGTH)
                          0)
                   (EQ (SKIPSEPRS FILE T)
                       '%")
                   (SETQ COM (CAR (NLSETQ (READ FILE T]
              (CLOSEF FILE)
              (COND
                 (RETFLG                                     (* ; "Save it to return"))
                 (T                                          (* ; "Unread a string")
                                                             (* ; 
                                   "RMK: Replace CR and LF by space to avoid EOL convention issues")
                    (for I from 1 to (NCHARS COM)
                       when (FMEMB (NTHCHARCODE COM I)
                                       (CHARCODE (CR LF EOL))) do (RPLCHARCODE COM I (CHARCODE
                                                                                          EOL)))
                    (BKSYSBUF COM]
          (RETURN (COND
                     (RETFLG COM)
                     (COM T])

(\USEREVENT
  [LAMBDA (EVENT)
    (DECLARE (GLOBALVARS AROUNDEXITFNS))             (* bvm%: "16-Dec-83 15:27")
    (for FN in (SELECTQ EVENT
                           ((BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM BEFOREMAKESYS) 
                                AROUNDEXITFNS)
                           (REVERSE AROUNDEXITFNS)) do (APPLY* FN EVENT])
)

(ADDTOVAR AROUNDEXITFNS )

(RPAQ? HERALDSTRING "")

(RPAQ? \USERNAME )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS)
)
(DEFINEQ

(USERNAME
  [LAMBDA (FLG STRPTR PRESERVECASE)                      (* lmm "28-MAR-82 14:10")
                                                             (* ; 
                                                    "On 10, USERNAME can take a user number as arg")
    (PROG (ADDR NAME)
          (SETQ NAME (COND
                        (FLG NIL)
                        ((NEQ 0 (SETQ ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage)))
                         (GetBcplString (\ADDBASE (EMADDRESS 0)
                                               ADDR)
                                (EQ STRPTR T)))
                        (T \USERNAME)))
          (OR PRESERVECASE (NULL NAME)
              (SETQ NAME (U-CASE NAME)))
          (RETURN (COND
                     ((NULL NAME)
                      NIL)
                     ((STRINGP STRPTR)
                      (SUBSTRING NAME 1 -1 STRPTR))
                     (T NAME])

(SETUSERNAME
  [LAMBDA (NAME)                                         (* lmm "28-MAR-82 14:11")
                                                             (* ; 
                                                           "Changed interpretation of UserName0")
    (COND
       (NAME (PROG ((ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage)))
                   (RETURN (COND
                              ((NEQ ADDR 0)
                               (SetBcplString (\ADDBASE (EMADDRESS 0)
                                                     ADDR)
                                      NAME)
                               (SETQ USERNAME (USERNAME NIL T)))
                              (T (SETQ \USERNAME (CONCAT NAME])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 

(FILESLOAD (LOADCOMP)
       FILEIO)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
)
(PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 
1991 1992 1920 2017 2020 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2705 9399 (DELFILE 2715 . 2876) (FULLNAME 2878 . 3245) (INFILE 3247 . 3395) (INFILEP 
3397 . 3532) (IOFILE 3534 . 3674) (OPENFILE 3676 . 4076) (OPENSTREAM 4078 . 8386) (OUTFILE 8388 . 8539
) (OUTFILEP 8541 . 8677) (RENAMEFILE 8679 . 8985) (SIMPLE.FINDFILE 8987 . 9397)) (9771 29362 (
UNPACKFILENAME 9781 . 9967) (UNPACKFILENAME.STRING 9969 . 26241) (LASTCHPOS 26243 . 26937) (
\UPF.NEXTPOS 26939 . 27584) (\UPF.TEMPFILEP 27586 . 28163) (FILENAMEFIELD 28165 . 28650) (PACKFILENAME
 28652 . 28995) (PACKFILENAME.STRING 28997 . 29360)) (51803 59344 (LOGOUT 51813 . 52774) (MAKESYS 
52776 . 54547) (SYSOUT 54549 . 56296) (SAVEVM 56298 . 57110) (HERALD 57112 . 57272) (INTERPRET.REM.CM 
57274 . 58967) (\USEREVENT 58969 . 59342)) (59526 61253 (USERNAME 59536 . 60492) (SETUSERNAME 60494 . 
61251)))))
STOP
\ No newline at end of file
diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM
index 1593d048..527f9214 100644
Binary files a/sources/ADIR.LCOM and b/sources/ADIR.LCOM differ
diff --git a/sources/ASKUSER b/sources/ASKUSER
index 84927ed4..694375fc 100644
--- a/sources/ASKUSER
+++ b/sources/ASKUSER
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "10-Aug-2020 21:18:50" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ASKUSER.;5 51071  

      changes to%:  (FNS ASKUSER)
                    (VARS ASKUSERCOMS)

      previous date%: "16-May-90 12:04:15" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ASKUSER.;1)


(* ; "
Copyright (c) 1986, 1987, 1990, 2020 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ASKUSERCOMS)

(RPAQQ ASKUSERCOMS
       [(FNS ASKUSER ASKUSERLOOKUP ASKUSERCHAR ASKUSER$ ASKUSER1 ASKUSERSETUP ASKUSEREXPLAIN 
             ASKUSERPRIN1 MAKEKEYLST)
        
        (* ;; "RMK: Avoid literal CR's on files.")

        (INITVARS [DEFAULTKEYLST `([Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL]
                                   (N ,(CONCAT "o" (CHARACTER (CHARCODE EOL]
               (ASKUSERTTBL (COPYTERMTABLE)))
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (CONTROL T ASKUSERTTBL)
                                           (ECHOMODE NIL ASKUSERTTBL)))
        (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS ASKUSER OPTIONS)
               (GLOBALVARS DEFAULTKEYLST ASKUSERTTBL))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA])
(DEFINEQ

(ASKUSER
  [LAMBDA (WAIT DEFAULT MESS KEYLST TYPEAHEAD LISPXPRNTFLG OPTIONSLST FILE)
    (DECLARE (SPECVARS LISPXPRNTFLG OPTIONSLST FILE))
                                                            (* ; "Edited 10-Aug-2020 20:58 by rmk:")
                                                             (* ; "Edited 10-Aug-87 15:45 by jop")
                                                             (* ; 
                   "reads characters one at a time echoing and/or prompting as indicated by KEYLST")

    (* ;; "RMK: Changed literal ^M's and spaces to use the (CHARACTER (CHARCODE construct), for readability and to allow for EOL conversion from other file systems.  We want this always to be the internal EOL (=CR).")

    (RESETLST
        (COND
           ((NULL KEYLST)                                    (* ; 
                                                         "Yes, no recognized without conforimation")
            (SETQ KEYLST DEFAULTKEYLST)))
        (PROG [OLDTTBL CHAR TEM KEYLST1 ANSWER BUFS (ORIGKEYLST KEYLST)
                     (ORIGMESS MESS)
                     (ORIGDEFAULT DEFAULT)
                     (NC 1)
                     KEY PROMPTSTRING OPTIONS NOECHOFLG CONFIRMFLG NOCASEFLG PRINTLST ECHOEDFLG
                     (EOL (CHARACTER (CHARCODE EOL)))
                     (SPACE (CHARACTER (CHARCODE SPACE]
              (COND
                 ((NULL FILE)
                  (SETQ FILE T))
                 ((NEQ FILE T)
                  (GO MESS)))
              (SETQ OLDTTBL (GETTERMTABLE))
              (RESETSAVE (SETTERMTABLE ASKUSERTTBL))

         (* ;; "ASKUSERTTBL has (CONTROL T) and (RAISE T) performed.  The latter means that if the user types lower case characters, they are converted to uppercase.  Note however that this will recognize lower case y and n.  This is so the caller can provide y or n as a default, and distinguish the default cse from the case where the user types lowercase y or n (which will be converted to uppercase automatically by the terminal table) ASKUSERTTBL also has (ECHOMODE NIL) performed so can handle mistypings and confirations properly.")
                                                             (* ; 
                                                           "File can be a file name or a string")
              (COND
                 (TYPEAHEAD                                  (* ; "TYPEAHEAD permitted")
                        (SETQ TYPEAHEAD (READP T))           (* ; 
                        "used in case there is a mistake.  in this case all typeahead is restored.")
                        (GO MESS)))
              (LINBUF)
              (SYSBUF)
              (SETQ BUFS (CLBUFS NIL T READBUF))

         (* ;; "Clear and save typeahead.  This call to CLBUFS will ring the bells if there is any typeahead to warn the user to stop typing.")

              (COND
                 [(LISTP MESS)
                  (ASKUSERPRIN1 (CAR MESS))
                  (COND
                     ((SETQ MESS (CDR MESS))
                      (ASKUSERPRIN1 " "))
                     (T (ASKUSERPRIN1 " ? "]
                 (MESS (ASKUSERPRIN1 MESS)
                       (SETQ MESS NIL)))

         (* ;; "The problem with user interactions such as this where typeahead is not allowed is that we have no way of knowing WHEN the user types something, i.e.  if he typed it after seeing part of the message or no, without doing a DOBE before doing any printing, and this is not desirable as it produces a noticeable snag in teletype output.  --- Therefore what we do is the following: all typeahead before the call to ASKUSER is cleared and saved for later restoration, and n the event ther is any typeahead, bells are rung to warn the user to stop typing.  (this is done by the call to CLBUFS above.) --- After that we print something, either the first part of the message or the message itself, to give the user time to respond to the warning to stop typing.  IN this interval, anything that is typed is thrown away.  After printing the message, we do a DOBE, and then check to see if user has typed anything.  If he has, this material is discarded, and bells printed again to warn him.")

              (DOBE)
              (COND
                 ((READP T)
                  (PRINTBELLS)
                  (DOBE)
                  (CLEARBUF T)))
          MESS
                                                             (* ; 
                        "MESS is either an atom or string or a list, in which case it is MAPRINTed")
              (COND
                 ((NULL MESS)                                (* ; 
                                    "Either user didnt supply a message or else was printed above.")
                  )
                 ((NLISTP MESS)
                  (ASKUSERPRIN1 MESS))
                 (T (MAPRINT MESS T NIL " ? " NIL NIL LISPXPRNTFLG)))
              (COND
                 ((OR (NOT (NUMBERP WAIT))
                      (NULL DEFAULT))                        (* ; 
                "is : either a number, meaning wait that many seconds or NIL, meaning wait forever")
                  (GO READLP)))
              [COND
                 ((AND DEFAULT (NLISTP DEFAULT))
                  (SETQ DEFAULT (LIST DEFAULT]
              (COND
                 ((NULL (WAITFORINPUT (ITIMES WAIT 1000)))   (* ; 
                                               "Assume DEFAULT if nothing typed in WAIT/4 seconds.")
                  (PRIN1 "..." T)
                  (SETQ CHAR (CAR DEFAULT))
                  (GO INTERP)))
          READLP
              [COND
                 ((AND (STRINGP FILE)
                       (NOT (READP FILE T)))
                  (SETQ FILE T)
                  (SETQ OLDTTBL (GETTERMTABLE))
                  (RESETSAVE (SETTERMTABLE ASKUSERTTBL]      (* ; "the string ran out")
              (SETQ CHAR (PEEKC FILE))                       (* ; 
                                 "PEEKC used so that in case of $ as a key, askuser can do a READ.")
              (SETQ ECHOEDFLG NIL)                           (* ; 
                                                 "this character has not yet been echoed.  or read")
              (SETQ DEFAULT NIL)
          INTERP
              

         (* ;; "KEYLST is a list of elements of the form (KEY PROMPTSTRING  . OPTIONS), where KEY is an atom or string (including the empty string) that characters are to be matched against, PROMPTSTRING a string or atom (NIL is equivalent to ''), and OPTIONS a list in property list format which can contain the properties (KEYLST CONFIRMFLG RETURN EXPLAINSTRING NOECHOFLG KEYSTRING PROMPTON COMPLETEON AUTOCOMPLETEFLG) Default options for the entire keylst can be supplied as an argument to ASKUSER --- --- A key is considered to be complete when (1) all of its characters have been matched and it is the only key left, i.e.  there are no other keys for which this key is a substring, (2) all of its characters have been matched, and CONFIRMFLG is NIL, and the next character matches one of the keys on its KEYLST, (3) all of its characters have been matched, and a confirming character is typed, i.e.  a c.r., space, or member of CONFIRMFLG (This option is used for implementing TENEX protocosl, where CONFIRMFLG is ($)) or (4) there is only one key left and a confirming character is typed.  --- --- When a key is complete, PROMPTSTRING is printed.  Then if CONFIRMFLG is non-NIL and the key was not completed via a confirming character (case 3 and 4 above) askuser waits for a confirming character.  --- --- After confirmation, if KEYLST is non NIL, askuser descends into KEYLST.  Otherwise askuser returns a value which is the value of (eval of) the RETURN field, if non-NIL, otherwise the result of packing all the keys or keystrings, if present --- see below on the path.  --- At any point, the user can type an alt-mode which is equivalent to typing the next n shared characters.  (if there are none, a bell is rung.) Typing a confirming character has the same effect as typing an alt-mode, i.e.  the next n shared characters will be supplied.  If the key is the only key left, confirmation is not required.  (this is case 4 above).  If the key is not the only key left, a bell is rung.  --- --- special options: --- EXPLAINSTRING if non-nil, used in place of key/keystring + promptstring when user types a ?  --- NOECHOFLG if non-nil, characters that are matched are not echoed --- KEYSTRING if non-nil, characters that are matched are echoed from keystring.  The main reason for this feature echoing, since ASKUSER converts everything to a canonical upper case form, keys will always be represented in uppercase.  KEYSTRING can be used to provide for lower case echoing, and for returning a lower case value.  i.e.  if the RETURN option is not specified, and KEYSTRING is specified, then KEYSTRING will be used in constructing the value to be returned, rather than KEY.  --- PROMPTON if non-NIL, PROMPTSTRING is printed only when the key is confirmed with a member of PROMPTON.  This feature is used for implementing TENEX protocols, in which case PROMPTON would be ($) Note that this doesnt make much sense unless CONFIRMFLG is also non-NIL and includes the elements on PROMPTON --- --- COMPLETEON when a confirming character is typed, the n characters that are supplied are not echoed unless the confirming charactter is a member of COMPLETEON.  This is used for implementing tenex protocols in which case COMPLETEON is ($), i.e.  user could complete a command with space or c.r.  but completion and prompting would take place only for $ --- --- AUTOCOMPLETEFLG if T, says supply characters as soon as they are unambiguous, i.e.  act as though alt-mode were typed after each character (but dont ring a bell) --- MACROCHARS, a list of characters and forms.  if one of the characters is typed, and doesnt match as a key, then the form is evaluated for effect and everything else stays the same, e.g.  ?  could have been implemented this way.  this feature is probably most useful when MACROCHARS is supplied on OPTIONSLST since one probably wants a global set of MACROCHARS for a call single call to askuser.  --- --- & as a key matches any character.  --- --- '' can be used as a key It starts out with all of its characters matched, so that it is complete if it is the only key left, (1) above, or the next character mtches one of the keys on its KEYLST, etc.  --- --- $ can be used as a key to match the result of doing a READ.  For example, the filepkg has as one of its entries on its keylst ('' 'file/list: ' KEYLST ($)) which means that if a character is typpd that does not match any of the other charactters on its keylst, the prompt message file/list: is printed, and a read is then performed and eturned as the value of the call to askuser.  --- --- --- For the more common useage, KEY is the same as (KEY NIL CONFIRMFLG T), and (KEY  . PROMPT) the same as (KEY PROMPT)")

              [SETQ KEYLST1 (for ENTRY in KEYLST eachtime (ASKUSERSETUP ENTRY)
                               collect ENTRY
                               when (COND
                                           ((ASKUSERCHAR CHAR (SETQ TEM (NTHCHAR KEY NC)))
                                                             (* ; 
                                                 "char matches the corresponding character in key.")
                                            T)
                                           ((OR TEM $$VAL (EQ CHAR '?))

                                 (* ;; "There was another character in the key, and char didnt match it.  The $$VAL check is to insure that once there has been a match with a character in a key atthis level, we do not treat space or c.r.  as terminators, so that space and c.r.  can be used as keys themselves, nor do we descend into subkeylists, and so thatthe user can specify a default match via '' as a place marker, and have it operate ONLY when other elements are not matched by placing it last on the keylst.  e.g.  if keylst is of the form ((c.r.  --) -- ('' -- subkeylst)) and a c.r.  is typed, matching wont go into subkeylst ADDTOFILES uses this feature")

                                            NIL)
                                           ((AND (NULL (ASKUSERLOOKUP 'CONFIRMFLG))
                                                 (ASKUSERLOOKUP 'KEYLST)
                                                 (ASKUSER1 ENTRY CHAR))

                                 (* ;; "We have already matched all the characters in key, and entry contains a lower keylst.  and char matches one of its elements, therefore do any prompting necessary for this key, and descend")

                                            (SETQ ANSWER (NCONC1 ANSWER (OR (ASKUSERLOOKUP
                                                                             'KEYSTRING)
                                                                            KEY)))
                                            [AND (NULL NOECHOFLG)
                                                 (SETQ PRINTLST (NCONC1 PRINTLST
                                                                       (OR (ASKUSERLOOKUP
                                                                            'KEYSTRING)
                                                                           KEY]
                                            [AND PROMPTSTRING (SETQ PRINTLST (NCONC1 PRINTLST
                                                                                    (PRIN1 
                                                                                         PROMPTSTRING
                                                                                           T]

                                            (* ;; "PRINTLST is maintained to implement the ?  feature and to be able to replay the output to put on the history.")

                                            (SETQ KEYLST (ASKUSERLOOKUP 'KEYLST))
                                            (SETQ NC 1)      (* ; 
                                               "CHAR will then be matched aainst the lower keylst.")
                                            (GO INTERP))
                                           ([COND
                                               ((LISTP CONFIRMFLG)
                                                (MEMB CHAR CONFIRMFLG))
                                               (T (OR (EQ CHAR EOL)
                                                      (EQ CHAR SPACE]

                                 (* ;; "all of its characters were matched, and this character was a c.r.  or space.  e.g.  CHARLST= (CLISP CLISPFLG CLISPTRANFLG) and CLISP c.r.  has been typed The check is made after the other checks so that space and carriage return themselves can be used in keys.  Note that it doesnt matter whether confirmflg is T or not, the user can still use c.r.  or space to terminate a key.")

                                            (AND (NULL NOECHOFLG)
                                                 (SETQ PRINTLST (NCONC1 PRINTLST CHAR)))
                                            T]
              (ASKUSERSETUP (CAR KEYLST))
              [COND
                 (KEYLST1 (SETQ KEYLST KEYLST1)
                        (GO RIGHT))
                 ((AND (NULL ANSWER)
                       (EQ NC 1)
                       (NULL DEFAULT)
                       (OR (EQ CHAR SPACE)
                           (EQ CHAR EOL)))                   (* ; 
                             "user typed eol  or space simply to keep dwim from defaulting on him.")
                  (AND (NULL NOECHOFLG)
                       (PRIN1 CHAR T))
                  (AND (READC FILE))
                  (GO READLP))
                 ([OR [EQ CHAR (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                      (COND
                         ((LISTP CONFIRMFLG)
                          (MEMB CHAR CONFIRMFLG))
                         (T (OR (EQ CHAR EOL)
                                (EQ CHAR SPACE]

                  (* ;; "altmode c.r.  or space says supply characters from atoms in this level of keylst until there are two or more atms with different characters at thatposition.  C.R.  and space is same as alt mode except if there is only one atom, then return without confirmation after supplying the characters.  If thee are not atms with common characters beyond this point, then ring a bell and take no action.")

                  [COND
                     ((NULL (SETQ TEM (ASKUSER$ KEYLST CHAR NC)))
                      (GO WRONG))
                     (T (SETQ NC (ADD1 TEM]
                  (AND (NULL DEFAULT)
                       (READC FILE))
                  (COND
                     ((NULL (CDR KEYLST))                    (* ; 
                                           "only one.  Therefore this character completes the key,")
                      (GO COMPLETED))
                     ((OR (EQ CHAR SPACE)
                          (EQ CHAR EOL))
                      (PRIN1 (CHARACTER (CHARCODE BELL))
                             T)                              (* ; "print a bell.")
                      ))
                  (GO NEXT))
                 ((OR (SYNTAXP (SETQ TEM (CHCON1 CHAR))
                             'CHARDELETE)
                      (SYNTAXP TEM 'LINEDELETE))             (* ; "control-a, q,")
                  (GO RETRY))
                 ([AND (NULL DEFAULT)
                       (EQ FILE T)
                       (SETQ TEM (FASSOC CHAR (ASKUSERLOOKUP 'MACROCHARS]
                  (READC T)
                  (SETTERMTABLE OLDTTBL)
                  (EVAL (CDR TEM))
                  (SETTERMTABLE ASKUSERTTBL)
                  (GO READLP))
                 ((AND (NULL DEFAULT)
                       (EQ CHAR '?)
                       (EQ FILE T))
                  (TERPRI T)
                  (READC T)
                  [NLSETQ (PROGN (PRIN1 (OR (fetch (OPTIONS EXPLAINSTRING) of OPTIONSLST)
                                            (CONCAT "one of:" EOL))
                                        T)
                                 (ASKUSEREXPLAIN KEYLST PRINTLST OPTIONSLST
                                        (OR (ASKUSERLOOKUP 'EXPLAINDELIMITER)
                                            EOL]
                  (TERPRI T)
                  [AND ORIGMESS (COND
                                   ((NLISTP ORIGMESS)
                                    (ASKUSERPRIN1 ORIGMESS))
                                   (T (MAPRINT ORIGMESS T NIL " ? " NIL NIL LISPXPRNTFLG]
                  [MAPC PRINTLST (FUNCTION (LAMBDA (X)
                                             (PRIN1 X T]
                  (AND (NEQ NC 1)
                       (PRIN1 (SUBSTRING [COND
                                            ((NLISTP (CAR KEYLST))
                                             (CAR KEYLST))
                                            (T (OR (fetch (ASKUSER KEYSTRING)
                                                      of (CAR KEYLST))
                                                   (fetch (ASKUSER KEY) of (CAR KEYLST]
                                     1
                                     (SUB1 NC))
                              T))

                  (* ;; "These are the characters that have been matched on this level key, but not yet added to answer or printlst.")

                  (GO READLP))
                 ([SETQ KEYLST1
                   (find X in KEYLST
                      suchthat (SELECTC X
                                       ([LIST '& (CHARACTER (CHARCODE ESCAPE))
                                              (PACKC (CHARCODE (ESCAPE ESCAPE] 
                                            (SETQ KEY X)
                                            T)
                                       (AND (LISTP X)
                                            (SELECTC (CAR X)
                                                ('& 
                                                     (COND
                                                        ((OR [NULL (SETQ TEM (LISTGET1 X 'CLASS]
                                                             (APPLY* TEM CHAR))
                                                         (SETQ KEY (CAR X))
                                                         T)))
                                                ([LIST (CHARACTER (CHARCODE ESCAPE))
                                                       (PACKC (CHARCODE (ESCAPE ESCAPE] 
                                                     (SETQ KEY (CAR X))
                                                     T)
                                                (AND (LISTP (CAR X))
                                                     (SETQ KEY (CAR X]
                  (COND
                     ((EQ KEY '&)
                      [SETQ KEYLST (LIST (CONS CHAR (AND (LISTP KEYLST1)
                                                         (CDR KEYLST1]
                      (GO RIGHT))
                     (T                                      (* ; "altmode.  or double-altmode")
                                                             (* (AND (EQ FILE T)
                                                           (PRIN1 CHAR T)))

                        (* ;; "The character would not have been echoed since the PEEKC was done with echomode off.  Since it has already been seen by LISP, it wold not be echoed by the READ below, even though ECHOMODE would then be turned on.  Therefore must print it.")

                        (SETTERMTABLE OLDTTBL)
                        (OR (PROG1 [NLSETQ (COND
                                              ([EQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                                               (SETQ TEM (READ FILE T)))
                                              [[EQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE]
                                               (LET (READBUF)
                                                    (DECLARE (SPECVARS READBUF))

                                 (* ;; "since READ is used, rather than lispxread for $ key, we should not have readline be affected by readbuf, e.g.  if user is redoing an event contaig an askuser, he wants to type in tuff again.")

                                                    (SETQ TEM (READLINE T]
                                              (T (SETQ TEM (EVAL KEY]
                                   (SETTERMTABLE ASKUSERTTBL))
                            (GO RETRY))
                        (SETQ KEYLST (LIST (create ASKUSER using (LISTP KEYLST1)
                                                                     KEY _ TEM)))
                        (SETQ NC (ADD1 (NCHARS TEM)))
                        (SETQ ECHOEDFLG T)                   (* ; 
                                   "so that the character terminatng the read wont be echoed twice")
                        [COND
                           [(SYNTAXP [SETQ TEM (CHCON1 (SETQ CHAR (LASTC FILE]
                                   'SEPR T)                  (* ; 
                                                       "character was included as part of the read")
                            (replace OPTIONS of (CAR KEYLST)
                               with (CONS 'CONFIRMFLG (CONS (LIST CHAR)
                                                                (fetch OPTIONS
                                                                   of (CAR KEYLST]
                           ((SYNTAXP TEM 'BREAK T)           (* ; "e.g.  read of a lit")
                            (GO READLP))
                           (T (SETQ CHAR (READC FILE]

                        (* ;; "(COND ((EQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE)))) (* (61  . 965) 130 <NEWLISP>ASSIST.;8 NIL) (SETQ CHAR (READC FILE))) ((EQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE))))) (SETQ CHAR (LASTC FILE)) (replace OPTIONS of (CAR KEYLST) with (CONS (QUOTE CONFIRMFLG) (CONS (QUOTE (] 
)) (fetch (ASKUSER OPTIONS) of (CAR KEYLST)))))) ((LISTP KEY) (* (73  . 955) 107 <NEWLISP>ASSIST.;30 NIL)) (T (SHOULDNT)))")

                        (SETQ DEFAULT '(T))

                        (* ;; "so wont attempt to read the character again.  reason we have to read it here, in the case of read, is that it has already been echoed, and in the case of a lower keylst, there would be no way to psass on the information about it having been echoed without setting echoedflg to T.  thus we cant go back to READLP, sice that wold set echoflg to NIL.")

                        (GO INTERP]
          WRONG
                                                             (* ; "user typed invalid answer")
              (AND (NEQ FILE T)
                   (ERROR!))
              (AND (NULL DEFAULT)
                   (READC FILE))
              (COND
                 (TYPEAHEAD (GO RETRY1)))
              (PRINTBELLS)
              (DOBE)
              (CLEARBUF T)
              (GO READLP)
          RIGHT
                                                             (* ; "character matched.")
              (AND (NULL DEFAULT)
                   (READC FILE))
          RIGHT1
              (ASKUSERSETUP (CAR KEYLST))
              (COND
                 ((OR (CDR KEYLST)
                      (ILESSP NC (NCHARS KEY)))              (* ; 
                                    "More than one candidate.  or this candidate not finished yet.")
                  (AND (NULL NOECHOFLG)
                       (EQ FILE T)
                       (SETQ TEM (COND
                                    ((SETQ TEM (ASKUSERLOOKUP 'KEYSTRING))

                                     (* ;; "primarily to allow specifying of echoing in lower case, even though askuser always converts to uppercase when it reads.")

                                     (NTHCHAR TEM NC))
                                    (T CHAR)))
                       (PRIN1 TEM T))
                  (SETQ NC (ADD1 NC))
                  [COND
                     ((AND (ASKUSERLOOKUP 'AUTOCOMPLETEFLG)
                           (SETQ TEM (ASKUSER$ KEYLST CHAR NC)))
                      (COND
                         ((AND (NULL (CDR KEYLST))
                               (EQ (SETQ NC TEM)
                                   (NCHARS KEY)))
                          (GO COMPLETED))
                         (T (SETQ NC (ADD1 TEM]
                  (GO NEXT)))                                (* ; 
                             "There is only one entry left, and all of its characters are matched.")
              (AND (NULL NOECHOFLG)
                   (EQ FILE T)
                   (EQ NC (NCHARS KEY))
                   (SETQ TEM (COND
                                ((SETQ TEM (ASKUSERLOOKUP 'KEYSTRING))
                                 (NTHCHAR TEM NC))
                                (T CHAR)))
                   (PRIN1 TEM T))

         (* ;; "the character is the last one in the key.  the case where a c.r.  was typed to terminate a key is handled below.")

          COMPLETED
              (SETQ ANSWER (NCONC1 ANSWER (OR (ASKUSERLOOKUP 'KEYSTRING)
                                              KEY)))
              [AND (NULL NOECHOFLG)
                   (SETQ PRINTLST (NCONC1 PRINTLST (OR (ASKUSERLOOKUP 'KEYSTRING)
                                                       KEY]
              [AND PROMPTSTRING (OR [NULL (SETQ TEM (ASKUSERLOOKUP 'PROMPTON]
                                    (MEMB CHAR TEM))
                   (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 PROMPTSTRING T]

         (* ;; "If PROMPTON is present, must wait till after confirmation to see if confirming charactter is PROMPTON (usually $).  this enables tenex like protocols.")

              (AND (NULL NOECHOFLG)
                   (EQ FILE T)
                   (IGREATERP NC (NCHARS KEY))
                   (PRIN1 (COND
                             ([AND (EQ CHAR EOL)
                                   (NULL (ASKUSERLOOKUP 'KEYLST]

                              (* ;; "space is echoed for all confirming characters except on a terminal leaf,in which char isused itself.")

                              CHAR)
                             (T SPACE))
                          T))
              (COND
                 ([OR (NULL CONFIRMFLG)
                      (COND
                         ((LISTP CONFIRMFLG)
                          (MEMB CHAR CONFIRMFLG))
                         (T (OR (EQ CHAR EOL)
                                (EQ CHAR SPACE]

                  (* ;; "CONFIRMFLG can be a list of characters that are acceptable for confirming.  e.g.  ($) can be used to implemente tenex like protocols.")

                  (GO CONFIRMED))
                 (T (GO CONFIRM)))
          NEXT
              (SETQ DEFAULT (CDR DEFAULT))

         (* ;; "DEFAULT stays one behind the current character so that we can tell if the character came from a default list.")

              (COND
                 ((NULL DEFAULT)
                  (GO READLP))
                 (T (SETQ CHAR (CAR DEFAULT))
                    (GO INTERP)))
              (GO INTERP)
          CONFIRM
              (COND
                 ((ASKUSERLOOKUP 'PROMPTCONFIRMFLG)
                  (PRIN1 " [confirm] " T)))
              [COND
                 ((AND (STRINGP FILE)
                       (NOT (READP FILE T)))
                  (SETQ FILE T)
                  (SETQ OLDTTBL (GETTERMTABLE))
                  (RESETSAVE (SETTERMTABLE ASKUSERTTBL]
              [SETQ CHAR (COND
                            ((SETQ DEFAULT (CDR DEFAULT))
                             (CAR DEFAULT))
                            (T (READC FILE]
              (COND
                 ((OR (SYNTAXP (SETQ TEM (CHCON1 CHAR))
                             'CHARDELETE)
                      (SYNTAXP TEM 'LINEDELETE))             (* ; "control-a or q")
                  (GO RETRY))
                 [(LISTP CONFIRMFLG)
                  (COND
                     ((MEMB CHAR CONFIRMFLG)                 (* ; "used for TENEX mode.")
                      [AND PROMPTSTRING (SETQ TEM (ASKUSERLOOKUP 'PROMPTON))
                           (MEMB CHAR TEM)
                           (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 PROMPTSTRING T]
                      (AND (NULL NOECHOFLG)
                           (PRIN1 SPACE T))
                      (GO CONFIRMED]
                 ((OR (EQ CHAR SPACE)
                      (EQ CHAR EOL))
                  [COND
                     ((NULL NOECHOFLG)
                      (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 (COND
                                                                ((NULL (ASKUSERLOOKUP
                                                                        'KEYLST))
                                                                 CHAR)
                                                                (T SPACE))
                                                             T]
                  (GO CONFIRMED))
                 ([SETQ TEM (FASSOC CHAR (ASKUSERLOOKUP 'MACROCHARS]
                  (SETTERMTABLE OLDTTBL)
                  (EVAL (CDR TEM))
                  (SETTERMTABLE ASKUSERTTBL)
                  (GO CONFIRM)))
              (COND
                 ((NEQ CHAR '?)
                  (PRIN1 (PACKC (CHARCODE (BELL ?)))
                         T)
                  (DOBE)
                  (CLEARBUF T)))
              (PRIN1 " [confirm] " T)
              (GO CONFIRM)
          CONFIRMED
              (COND
                 ((SETQ TEM (ASKUSERLOOKUP 'KEYLST))
                  (SETQ KEYLST TEM)
                  (SETQ NC 1)
                  (GO NEXT)))
              (COND
                 (LISPXPRNTFLG [MAPC PRINTLST (FUNCTION (LAMBDA (X)
                                                          (ASKUSERPRIN1 X T]
                                                             (* ; 
                                                         "fakes the printing for the history list.")
                        ))
              (COND
                 (BUFS (BKBUFS BUFS)))
              (RETURN (COND
                         [(SETQ TEM (OR (FMEMB 'RETURN OPTIONS)
                                        (FMEMB 'RETURN OPTIONSLST)))
                          (SETTERMTABLE OLDTTBL)
                          (COND
                             ([SETQ TEM (NLSETQ (EVAL (CADR TEM]

                              (* ;; "ASKUSERLOOKUP (QUOTE not) used since then couldnt distinguish case where RETURN NIL was specified from case where RETURN was not specified at all.")

                              (* ;; "This permits user to return ANSWER as a list itself, or to take some other action, and then restart by simply generateing an error.")

                              (CAR TEM))
                             (T (SETTERMTABLE ASKUSERTTBL)
                                (GO RETRY]
                         (ANSWER (PACK ANSWER))
                         (T (NOTCHECKED)
                            KEY)))
          RETRY
              (COND
                 (TYPEAHEAD (GO RETRY1)))
              (PRIN1 "___" T)
              (TERPRI T)
              (DOBE)
              (CLEARBUF T)
              (SETQ KEYLST ORIGKEYLST)
              (SETQ PRINTLST NIL)
              (SETQ NC 1)
              (SETQ ANSWER NIL)
              (GO READLP)
          RETRY1
              

         (* ;; "User has typed ahead before the call to askuser1 and his resonse is invalid.  therefore assume he didnt know that askuser would be called and his typeahead was intended for what follows.  clear and ave the typeahead and continue with interaction.")

              (LINBUF)
              (SYSBUF)
              (SETQ BUFS (CLBUFS NIL T READBUF))
              [SETQ TEM (APPLY 'CONCAT (NCONC ANSWER [AND (NEQ NC 1)
                                                          (LIST (SUBSTRING (COND
                                                                              ((LISTP (CAR KEYLST))
                                                                               (CAAR KEYLST))
                                                                              (T (CAR KEYLST)))
                                                                       1
                                                                       (SUB1 NC]
                                              (LIST CHAR]
              [COND
                 ((NULL BUFS)
                  (SETQ BUFS (CONS NIL TEM)))
                 (T (RPLACD BUFS (COND
                                    ((CDR BUFS)
                                     (CONCAT TEM (CDR BUFS)))
                                    (T TEM]
              (SETQ TYPEAHEAD NIL)                           (* ; "so this is only done once")
              (SETQ ANSWER NIL)
              (SETQ KEYLST ORIGKEYLST)
              (SETQ MESS ORIGMESS)
              (SETQ DEFAULT ORIGDEFAULT)
              (SETQ PRINTLST NIL)
              (TERPRI T)
              (GO MESS)))])

(ASKUSERLOOKUP
  [LAMBDA (FIELD)                                            (* bvm%: "26-Apr-86 17:14")
          
          (* * this wuld be just a fetch, xcept want to lok it up on optionslst if not 
          found on options.)

    (CADR (OR (FMEMB FIELD OPTIONS)
              (FMEMB FIELD OPTIONSLST])

(ASKUSERCHAR
  [LAMBDA (C1 C2)                                            (* bvm%: "26-Apr-86 17:27")
    (COND
       ((EQ C1 C2))
       ((AND (NULL NOCASEFLG)
             C2)
        (SETQ C1 (CHCON1 C1))
        (SETQ C2 (CHCON1 C2))
        (COND
           [(AND (IGEQ C1 (CHARCODE a))
                 (ILEQ C1 (CHARCODE z)))
            (EQ C2 (IDIFFERENCE C1 (IDIFFERENCE (CHARCODE a)
                                          (CHARCODE A]
           ((AND (IGEQ C2 (CHARCODE a))
                 (ILEQ C2 (CHARCODE z)))
            (EQ C1 (IDIFFERENCE C2 (IDIFFERENCE (CHARCODE a)
                                          (CHARCODE A])

(ASKUSER$
  [LAMBDA (KEYLST CHAR NC)                                   (* bvm%: "26-Apr-86 17:13")
    (for ENTRY bind NC0 KEY0 TEM in KEYLST eachtime [SETQ KEY (COND
                                                                 ((NLISTP ENTRY)
                                                                  ENTRY)
                                                                 (T (fetch (ASKUSER KEY) of ENTRY]
       when [AND [NEQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                 (NEQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE]
       do [COND
             ((NULL KEY0)                                    (* first time through)
              [SETQ KEY0 (COND
                            ((NLISTP (CAR KEYLST))
                             (CAR KEYLST))
                            (T (fetch (ASKUSER KEY) of (CAR KEYLST]
              (SETQ NC0 (NCHARS KEY0)))
             (T 
          
          (* Goes through keylst and looks at each key and determines the largest N for 
          which NTHCHAR of thatcharacter is equal for every atom.)

                (SETQ NC0 (for I from 1 to NC0 while (EQ (NTHCHARCODE KEY I)
                                                         (NTHCHARCODE KEY0 I))
                             finally (RETURN (SUB1 I]
       finally (COND
                  ((OR (NULL NC0)
                       (ILESSP NC0 NC))                      (* all atoms have different characters 
                                                             at this position.)
                   (RETURN NIL)))
             (ASKUSERSETUP (CAR KEYLST))
             [SETQ TEM (AND (OR [NULL (SETQ TEM (ASKUSERLOOKUP 'COMPLETEON]
                                (MEMB CHAR TEM))
                            (SUBSTRING (OR (ASKUSERLOOKUP 'KEYSTRING)
                                           KEY)
                                   NC
                                   (COND
                                      ((EQ (NCHARS KEY0)
                                           NC0)
          
          (* reason for this is in case KEYSTRING is longer, will get all of it.)

                                       -1)
                                      (T NC0] 
          
          (* if COMPLETEON is $ means only complete on alt-mode.
          this is used for tenex type protocol)

             (AND (NULL NOECHOFLG)
                  TEM
                  (PRIN1 TEM T)) 
          
          (* Reason for not just using value of noechoflg is that askusersetup oul have 
          set noechoflg to T when reading from a string in order to suppress echoing of 
          the character, but this does not mean that we do not echo the characters that 
          are supplied for copleting.)

             (RETURN NC0])

(ASKUSER1
  [LAMBDA (ENTRY CHAR)                                       (* DD%: "26-Oct-81 12:34")
          
          (* We know that ENTRY contains a subkeylst.
          This function sees if char could conceivably match one of the entries on 
          keylst.)

    (thereis ENTRY bind TEM in (fetch (ASKUSER KEYLST) of ENTRY)
       eachtime [SETQ TEM (COND
                             ((NLISTP ENTRY)
                              ENTRY)
                             (T (fetch (ASKUSER KEY) of ENTRY]
       suchthat (OR (EQ TEM '&)
                    [EQ TEM (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                    [EQ TEM (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE]
                    (LISTP TEM)
                    (EQ (SETQ TEM (NTHCHAR TEM 1))
                        CHAR)
                    (AND (NULL TEM)
                         (LISTP ENTRY)
                         (LISTP (CDR ENTRY))
                         (ASKUSER1 ENTRY CHAR])

(ASKUSERSETUP
  [LAMBDA (ENTRY)                                            (* bvm%: "26-Apr-86 17:13")
                                                             (* Sets free variables KEY, 
                                                             CONFIRMFLG, QUIETFLG, and PROMPTSTRING)
    (PROG (TEM)
          [COND
             [(NLISTP ENTRY)
              (SETQ KEY ENTRY)
              (SETQ PROMPTSTRING NIL)
              (SETQ OPTIONS NIL)
          
          (* The default is for NOECHOFLG to be NIL and CONFIRMFLG to be T.)

              (SETQ CONFIRMFLG (COND
                                  ((SETQ TEM (MEMB 'CONFIRMFLG OPTIONSLST))
                                   (CADR TEM))
                                  (T T]
             [(NLISTP (CDR ENTRY))
              (SETQ KEY (CAR ENTRY))
              (SETQ PROMPTSTRING (CDR ENTRY))
              (SETQ OPTIONS NIL)
              (SETQ CONFIRMFLG (COND
                                  ((SETQ TEM (MEMB 'CONFIRMFLG OPTIONSLST))
                                   (CADR TEM))
                                  (T T]
             (T (SETQ KEY (fetch (ASKUSER KEY) of ENTRY))
                (SETQ PROMPTSTRING (fetch (ASKUSER PROMPTSTRING) of ENTRY))
                (SETQ OPTIONS (fetch (ASKUSER OPTIONS) of ENTRY))
                (SETQ CONFIRMFLG (ASKUSERLOOKUP 'CONFIRMFLG]
          (SETQ NOECHOFLG (ASKUSERLOOKUP 'NOECHOFLG))
          (SETQ NOCASEFLG (ASKUSERLOOKUP 'NOCASEFLG))
          (AND ECHOEDFLG (SETQ NOECHOFLG T))
          (COND
             ((AND (NEQ FILE T)
                   (STRINGP FILE)
                   (READP FILE T))
              (SETQ NOECHOFLG T)
              (SETQ PROMPTSTRING NIL)
          
          (* askusersetup is called after the character has been read.
          Thus, this sets noechoflg to T and promptstring to NIL only if there are more 
          characters to be read. However, the check on whether or not the character JUST 
          read is to bechoed alsoincludes an (EQ FILE T) check)

              ])

(ASKUSEREXPLAIN
  [LAMBDA (KEYLST PREV OPTIONSLST DELIMITER)                 (* bvm%: "26-Apr-86 17:13")
    (MAPC KEYLST (FUNCTION (LAMBDA (ENTRY)
                             (PROG (KEY CONFIRMFLG NOECHOFLG PROMPTSTRING TEM OPTIONS (FILE T))
                                   (ASKUSERSETUP ENTRY)
                                   (COND
                                      ((SETQ TEM (ASKUSERLOOKUP 'KEYLST))
                                                             (* entry is of the form
                                                             (key prompt charlst))
                                       (ASKUSEREXPLAIN
                                        TEM
                                        [COND
                                           ((SETQ TEM (fetch (OPTIONS EXPLAINSTRING) of OPTIONS))
          
          (* reason for not using askuserlookup is that don't want top level 
          explainstring on ptionslst, if any. doesnt make sense to print it each time.
          it is printed only once.)

                                            (APPEND PREV (LIST TEM)))
                                           (T (APPEND PREV (AND (NULL NOECHOFLG)
                                                                (LIST (OR (ASKUSERLOOKUP 'KEYSTRING)
                                                                          KEY)))
                                                     (AND PROMPTSTRING (LIST PROMPTSTRING]
                                        OPTIONSLST DELIMITER)
                                       (RETURN)))
                                   [MAPC PREV (FUNCTION (LAMBDA (X)
                                                          (COND
                                                             ((LISTP X)
                                                              (MAPRINT X T))
                                                             (T (PRIN1 X T]
                                   [COND
                                      [(SETQ TEM (fetch (OPTIONS EXPLAINSTRING) of OPTIONS))
                                       (COND
                                          ((LISTP TEM)
                                           (MAPRINT TEM T))
                                          (T (PRIN1 TEM T]
                                      ((SETQ TEM (OR (ASKUSERLOOKUP 'KEYSTRING)
                                                     KEY))
                                       (AND (NULL NOECHOFLG)
                                            [NEQ TEM (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                                            (NEQ TEM '&)
                                            (PRIN1 TEM T))
          
          (* If the user wants to explain the & or $, he can include the appropriate text 
          in the prompt field.)

                                       (AND PROMPTSTRING (PRIN1 PROMPTSTRING T]
                                   (AND (NEQ (POSITION T)
                                             0)
                                        (PRIN1 DELIMITER T))
                                   (RETURN])

(ASKUSERPRIN1
  [LAMBDA (X NODOFLG)                                        (* wt%: % 4-DEC-75 00%:39)
          
          (* does a lispxprin1 if lispxprntflg is non-NIL.
          used to be done by having everythin printed with lispxprin1 and doing a 
          resetsave on lisxpprintflg, but this costs several conses each call.)

    (COND
       ((NULL LISPXPRNTFLG)
        (OR NODOFLG (PRIN1 X T)))
       (T (LISPXPRIN1 X T NIL NODOFLG)))
    X])

(MAKEKEYLST
  [LAMBDA (LST DEFAULTKEY LCASFLG AUTOCOMPLETEFLG)           (* wt%: "14-NOV-78 02:03")
    (PROG (TEM)
          (RETURN (NCONC [SETQ TEM (MAPCAR LST (FUNCTION (LAMBDA (KEY)
                                                           (LIST
                                                            KEY NIL 'KEYSTRING
                                                            (CONCAT (COND
                                                                       ((AND LCASFLG
                                                                             (EQUAL KEY (U-CASE
                                                                                         KEY)))
                                                             (* when ucasep gets in system, use it 
                                                             instead)
                                                                        (L-CASE KEY))
                                                                       (T KEY))
                                                                   " ")
                                                            'CONFIRMFLG T 'AUTOCOMPLETEFLG 
                                                            AUTOCOMPLETEFLG 'RETURN (KWOTE KEY]
                         [for X in TEM bind KEYSTRING as I from 1
                            collect (SETQ KEYSTRING (LISTGET X 'KEYSTRING))
                                  (LIST I KEYSTRING 'NOECHOFLG T 'EXPLAINSTRING (CONCAT I " - " 
                                                                                       KEYSTRING)
                                        'CONFIRMFLG T 'RETURN (LIST 'PROGN '(TERPRI T)
                                                                    (KWOTE (CAR X]
                         (COND
                            [(NULL DEFAULTKEY)
                             (LIST '("No - none of the above " "" CONFIRMFLG T AUTOCOMPLETEFLG T 
                                           RETURN NIL]
                            ((LISTP DEFAULTKEY)
          
          (* so user can specify no default key by simply calling with defaultkey=T)

                             (LIST DEFAULTKEY])
)



(* ;; "RMK: Avoid literal CR's on files.")


(RPAQ? DEFAULTKEYLST `[[Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL]
                           (N ,(CONCAT "o" (CHARACTER (CHARCODE EOL])

(RPAQ? ASKUSERTTBL (COPYTERMTABLE))
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(CONTROL T ASKUSERTTBL)

(ECHOMODE NIL ASKUSERTTBL)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD ASKUSER (KEY PROMPTSTRING . OPTIONS)
                    (SYSTEM))

(PROPRECORD OPTIONS (KEYLST CONFIRMFLG RETURN EXPLAINSTRING NOECHOFLG KEYSTRING PROMPTON 
                               COMPLETEON AUTOCOMPLETEFLG MACROCHARS NOCASEFLG PROMPTCONFIRMFLG CLASS
                               )
                        (SYSTEM))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DEFAULTKEYLST ASKUSERTTBL)
)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS ASKUSER COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 2020))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1432 50029 (ASKUSER 1442 . 37029) (ASKUSERLOOKUP 37031 . 37359) (ASKUSERCHAR 37361 . 
38020) (ASKUSER$ 38022 . 40930) (ASKUSER1 40932 . 41963) (ASKUSERSETUP 41965 . 44094) (ASKUSEREXPLAIN 
44096 . 47291) (ASKUSERPRIN1 47293 . 47769) (MAKEKEYLST 47771 . 50027)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "12-Feb-2021 17:00:02" {DSK}<home>larry>ilisp>medley>sources>ASKUSER.;8 51035  

      changes to%:  (VARS ASKUSERCOMS)

      previous date%: "10-Aug-2020 21:18:50" {DSK}<home>larry>ilisp>medley>sources>ASKUSER.;7)


(* ; "
Copyright (c) 1986, 1987, 1990, 2020, 2021 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT ASKUSERCOMS)

(RPAQQ ASKUSERCOMS
       [(FNS ASKUSER ASKUSERLOOKUP ASKUSERCHAR ASKUSER$ ASKUSER1 ASKUSERSETUP ASKUSEREXPLAIN 
             ASKUSERPRIN1 MAKEKEYLST)
        
        (* ;; "RMK: Avoid literal CR's on files.")

        (INITVARS [DEFAULTKEYLST (LIST [LIST 'Y (CONCAT "es" (CHARACTER (CHARCODE EOL]
                                       (LIST 'N (CONCAT "o" (CHARACTER (CHARCODE EOL]
               (ASKUSERTTBL (COPYTERMTABLE)))
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (CONTROL T ASKUSERTTBL)
                                           (ECHOMODE NIL ASKUSERTTBL)))
        (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS ASKUSER OPTIONS)
               (GLOBALVARS DEFAULTKEYLST ASKUSERTTBL))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA])
(DEFINEQ

(ASKUSER
  [LAMBDA (WAIT DEFAULT MESS KEYLST TYPEAHEAD LISPXPRNTFLG OPTIONSLST FILE)
    (DECLARE (SPECVARS LISPXPRNTFLG OPTIONSLST FILE))
                                                            (* ; "Edited 10-Aug-2020 20:58 by rmk:")
                                                             (* ; "Edited 10-Aug-87 15:45 by jop")
                                                             (* ; 
                   "reads characters one at a time echoing and/or prompting as indicated by KEYLST")

    (* ;; "RMK: Changed literal ^M's and spaces to use the (CHARACTER (CHARCODE construct), for readability and to allow for EOL conversion from other file systems.  We want this always to be the internal EOL (=CR).")

    (RESETLST
        (COND
           ((NULL KEYLST)                                    (* ; 
                                                         "Yes, no recognized without conforimation")
            (SETQ KEYLST DEFAULTKEYLST)))
        (PROG [OLDTTBL CHAR TEM KEYLST1 ANSWER BUFS (ORIGKEYLST KEYLST)
                     (ORIGMESS MESS)
                     (ORIGDEFAULT DEFAULT)
                     (NC 1)
                     KEY PROMPTSTRING OPTIONS NOECHOFLG CONFIRMFLG NOCASEFLG PRINTLST ECHOEDFLG
                     (EOL (CHARACTER (CHARCODE EOL)))
                     (SPACE (CHARACTER (CHARCODE SPACE]
              (COND
                 ((NULL FILE)
                  (SETQ FILE T))
                 ((NEQ FILE T)
                  (GO MESS)))
              (SETQ OLDTTBL (GETTERMTABLE))
              (RESETSAVE (SETTERMTABLE ASKUSERTTBL))

         (* ;; "ASKUSERTTBL has (CONTROL T) and (RAISE T) performed.  The latter means that if the user types lower case characters, they are converted to uppercase.  Note however that this will recognize lower case y and n.  This is so the caller can provide y or n as a default, and distinguish the default cse from the case where the user types lowercase y or n (which will be converted to uppercase automatically by the terminal table) ASKUSERTTBL also has (ECHOMODE NIL) performed so can handle mistypings and confirations properly.")
                                                             (* ; 
                                                           "File can be a file name or a string")
              (COND
                 (TYPEAHEAD                                  (* ; "TYPEAHEAD permitted")
                        (SETQ TYPEAHEAD (READP T))           (* ; 
                        "used in case there is a mistake.  in this case all typeahead is restored.")
                        (GO MESS)))
              (LINBUF)
              (SYSBUF)
              (SETQ BUFS (CLBUFS NIL T READBUF))

         (* ;; "Clear and save typeahead.  This call to CLBUFS will ring the bells if there is any typeahead to warn the user to stop typing.")

              (COND
                 [(LISTP MESS)
                  (ASKUSERPRIN1 (CAR MESS))
                  (COND
                     ((SETQ MESS (CDR MESS))
                      (ASKUSERPRIN1 " "))
                     (T (ASKUSERPRIN1 " ? "]
                 (MESS (ASKUSERPRIN1 MESS)
                       (SETQ MESS NIL)))

         (* ;; "The problem with user interactions such as this where typeahead is not allowed is that we have no way of knowing WHEN the user types something, i.e.  if he typed it after seeing part of the message or no, without doing a DOBE before doing any printing, and this is not desirable as it produces a noticeable snag in teletype output.  --- Therefore what we do is the following: all typeahead before the call to ASKUSER is cleared and saved for later restoration, and n the event ther is any typeahead, bells are rung to warn the user to stop typing.  (this is done by the call to CLBUFS above.) --- After that we print something, either the first part of the message or the message itself, to give the user time to respond to the warning to stop typing.  IN this interval, anything that is typed is thrown away.  After printing the message, we do a DOBE, and then check to see if user has typed anything.  If he has, this material is discarded, and bells printed again to warn him.")

              (DOBE)
              (COND
                 ((READP T)
                  (PRINTBELLS)
                  (DOBE)
                  (CLEARBUF T)))
          MESS
                                                             (* ; 
                        "MESS is either an atom or string or a list, in which case it is MAPRINTed")
              (COND
                 ((NULL MESS)                                (* ; 
                                    "Either user didnt supply a message or else was printed above.")
                  )
                 ((NLISTP MESS)
                  (ASKUSERPRIN1 MESS))
                 (T (MAPRINT MESS T NIL " ? " NIL NIL LISPXPRNTFLG)))
              (COND
                 ((OR (NOT (NUMBERP WAIT))
                      (NULL DEFAULT))                        (* ; 
                "is : either a number, meaning wait that many seconds or NIL, meaning wait forever")
                  (GO READLP)))
              [COND
                 ((AND DEFAULT (NLISTP DEFAULT))
                  (SETQ DEFAULT (LIST DEFAULT]
              (COND
                 ((NULL (WAITFORINPUT (ITIMES WAIT 1000)))   (* ; 
                                               "Assume DEFAULT if nothing typed in WAIT/4 seconds.")
                  (PRIN1 "..." T)
                  (SETQ CHAR (CAR DEFAULT))
                  (GO INTERP)))
          READLP
              [COND
                 ((AND (STRINGP FILE)
                       (NOT (READP FILE T)))
                  (SETQ FILE T)
                  (SETQ OLDTTBL (GETTERMTABLE))
                  (RESETSAVE (SETTERMTABLE ASKUSERTTBL]      (* ; "the string ran out")
              (SETQ CHAR (PEEKC FILE))                       (* ; 
                                 "PEEKC used so that in case of $ as a key, askuser can do a READ.")
              (SETQ ECHOEDFLG NIL)                           (* ; 
                                                 "this character has not yet been echoed.  or read")
              (SETQ DEFAULT NIL)
          INTERP
              

         (* ;; "KEYLST is a list of elements of the form (KEY PROMPTSTRING  . OPTIONS), where KEY is an atom or string (including the empty string) that characters are to be matched against, PROMPTSTRING a string or atom (NIL is equivalent to ''), and OPTIONS a list in property list format which can contain the properties (KEYLST CONFIRMFLG RETURN EXPLAINSTRING NOECHOFLG KEYSTRING PROMPTON COMPLETEON AUTOCOMPLETEFLG) Default options for the entire keylst can be supplied as an argument to ASKUSER --- --- A key is considered to be complete when (1) all of its characters have been matched and it is the only key left, i.e.  there are no other keys for which this key is a substring, (2) all of its characters have been matched, and CONFIRMFLG is NIL, and the next character matches one of the keys on its KEYLST, (3) all of its characters have been matched, and a confirming character is typed, i.e.  a c.r., space, or member of CONFIRMFLG (This option is used for implementing TENEX protocosl, where CONFIRMFLG is ($)) or (4) there is only one key left and a confirming character is typed.  --- --- When a key is complete, PROMPTSTRING is printed.  Then if CONFIRMFLG is non-NIL and the key was not completed via a confirming character (case 3 and 4 above) askuser waits for a confirming character.  --- --- After confirmation, if KEYLST is non NIL, askuser descends into KEYLST.  Otherwise askuser returns a value which is the value of (eval of) the RETURN field, if non-NIL, otherwise the result of packing all the keys or keystrings, if present --- see below on the path.  --- At any point, the user can type an alt-mode which is equivalent to typing the next n shared characters.  (if there are none, a bell is rung.) Typing a confirming character has the same effect as typing an alt-mode, i.e.  the next n shared characters will be supplied.  If the key is the only key left, confirmation is not required.  (this is case 4 above).  If the key is not the only key left, a bell is rung.  --- --- special options: --- EXPLAINSTRING if non-nil, used in place of key/keystring + promptstring when user types a ?  --- NOECHOFLG if non-nil, characters that are matched are not echoed --- KEYSTRING if non-nil, characters that are matched are echoed from keystring.  The main reason for this feature echoing, since ASKUSER converts everything to a canonical upper case form, keys will always be represented in uppercase.  KEYSTRING can be used to provide for lower case echoing, and for returning a lower case value.  i.e.  if the RETURN option is not specified, and KEYSTRING is specified, then KEYSTRING will be used in constructing the value to be returned, rather than KEY.  --- PROMPTON if non-NIL, PROMPTSTRING is printed only when the key is confirmed with a member of PROMPTON.  This feature is used for implementing TENEX protocols, in which case PROMPTON would be ($) Note that this doesnt make much sense unless CONFIRMFLG is also non-NIL and includes the elements on PROMPTON --- --- COMPLETEON when a confirming character is typed, the n characters that are supplied are not echoed unless the confirming charactter is a member of COMPLETEON.  This is used for implementing tenex protocols in which case COMPLETEON is ($), i.e.  user could complete a command with space or c.r.  but completion and prompting would take place only for $ --- --- AUTOCOMPLETEFLG if T, says supply characters as soon as they are unambiguous, i.e.  act as though alt-mode were typed after each character (but dont ring a bell) --- MACROCHARS, a list of characters and forms.  if one of the characters is typed, and doesnt match as a key, then the form is evaluated for effect and everything else stays the same, e.g.  ?  could have been implemented this way.  this feature is probably most useful when MACROCHARS is supplied on OPTIONSLST since one probably wants a global set of MACROCHARS for a call single call to askuser.  --- --- & as a key matches any character.  --- --- '' can be used as a key It starts out with all of its characters matched, so that it is complete if it is the only key left, (1) above, or the next character mtches one of the keys on its KEYLST, etc.  --- --- $ can be used as a key to match the result of doing a READ.  For example, the filepkg has as one of its entries on its keylst ('' 'file/list: ' KEYLST ($)) which means that if a character is typpd that does not match any of the other charactters on its keylst, the prompt message file/list: is printed, and a read is then performed and eturned as the value of the call to askuser.  --- --- --- For the more common useage, KEY is the same as (KEY NIL CONFIRMFLG T), and (KEY  . PROMPT) the same as (KEY PROMPT)")

              [SETQ KEYLST1 (for ENTRY in KEYLST eachtime (ASKUSERSETUP ENTRY)
                               collect ENTRY
                               when (COND
                                           ((ASKUSERCHAR CHAR (SETQ TEM (NTHCHAR KEY NC)))
                                                             (* ; 
                                                 "char matches the corresponding character in key.")
                                            T)
                                           ((OR TEM $$VAL (EQ CHAR '?))

                                 (* ;; "There was another character in the key, and char didnt match it.  The $$VAL check is to insure that once there has been a match with a character in a key atthis level, we do not treat space or c.r.  as terminators, so that space and c.r.  can be used as keys themselves, nor do we descend into subkeylists, and so thatthe user can specify a default match via '' as a place marker, and have it operate ONLY when other elements are not matched by placing it last on the keylst.  e.g.  if keylst is of the form ((c.r.  --) -- ('' -- subkeylst)) and a c.r.  is typed, matching wont go into subkeylst ADDTOFILES uses this feature")

                                            NIL)
                                           ((AND (NULL (ASKUSERLOOKUP 'CONFIRMFLG))
                                                 (ASKUSERLOOKUP 'KEYLST)
                                                 (ASKUSER1 ENTRY CHAR))

                                 (* ;; "We have already matched all the characters in key, and entry contains a lower keylst.  and char matches one of its elements, therefore do any prompting necessary for this key, and descend")

                                            (SETQ ANSWER (NCONC1 ANSWER (OR (ASKUSERLOOKUP
                                                                             'KEYSTRING)
                                                                            KEY)))
                                            [AND (NULL NOECHOFLG)
                                                 (SETQ PRINTLST (NCONC1 PRINTLST
                                                                       (OR (ASKUSERLOOKUP
                                                                            'KEYSTRING)
                                                                           KEY]
                                            [AND PROMPTSTRING (SETQ PRINTLST (NCONC1 PRINTLST
                                                                                    (PRIN1 
                                                                                         PROMPTSTRING
                                                                                           T]

                                            (* ;; "PRINTLST is maintained to implement the ?  feature and to be able to replay the output to put on the history.")

                                            (SETQ KEYLST (ASKUSERLOOKUP 'KEYLST))
                                            (SETQ NC 1)      (* ; 
                                               "CHAR will then be matched aainst the lower keylst.")
                                            (GO INTERP))
                                           ([COND
                                               ((LISTP CONFIRMFLG)
                                                (MEMB CHAR CONFIRMFLG))
                                               (T (OR (EQ CHAR EOL)
                                                      (EQ CHAR SPACE]

                                 (* ;; "all of its characters were matched, and this character was a c.r.  or space.  e.g.  CHARLST= (CLISP CLISPFLG CLISPTRANFLG) and CLISP c.r.  has been typed The check is made after the other checks so that space and carriage return themselves can be used in keys.  Note that it doesnt matter whether confirmflg is T or not, the user can still use c.r.  or space to terminate a key.")

                                            (AND (NULL NOECHOFLG)
                                                 (SETQ PRINTLST (NCONC1 PRINTLST CHAR)))
                                            T]
              (ASKUSERSETUP (CAR KEYLST))
              [COND
                 (KEYLST1 (SETQ KEYLST KEYLST1)
                        (GO RIGHT))
                 ((AND (NULL ANSWER)
                       (EQ NC 1)
                       (NULL DEFAULT)
                       (OR (EQ CHAR SPACE)
                           (EQ CHAR EOL)))                   (* ; 
                             "user typed eol  or space simply to keep dwim from defaulting on him.")
                  (AND (NULL NOECHOFLG)
                       (PRIN1 CHAR T))
                  (AND (READC FILE))
                  (GO READLP))
                 ([OR [EQ CHAR (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                      (COND
                         ((LISTP CONFIRMFLG)
                          (MEMB CHAR CONFIRMFLG))
                         (T (OR (EQ CHAR EOL)
                                (EQ CHAR SPACE]

                  (* ;; "altmode c.r.  or space says supply characters from atoms in this level of keylst until there are two or more atms with different characters at thatposition.  C.R.  and space is same as alt mode except if there is only one atom, then return without confirmation after supplying the characters.  If thee are not atms with common characters beyond this point, then ring a bell and take no action.")

                  [COND
                     ((NULL (SETQ TEM (ASKUSER$ KEYLST CHAR NC)))
                      (GO WRONG))
                     (T (SETQ NC (ADD1 TEM]
                  (AND (NULL DEFAULT)
                       (READC FILE))
                  (COND
                     ((NULL (CDR KEYLST))                    (* ; 
                                           "only one.  Therefore this character completes the key,")
                      (GO COMPLETED))
                     ((OR (EQ CHAR SPACE)
                          (EQ CHAR EOL))
                      (PRIN1 (CHARACTER (CHARCODE BELL))
                             T)                              (* ; "print a bell.")
                      ))
                  (GO NEXT))
                 ((OR (SYNTAXP (SETQ TEM (CHCON1 CHAR))
                             'CHARDELETE)
                      (SYNTAXP TEM 'LINEDELETE))             (* ; "control-a, q,")
                  (GO RETRY))
                 ([AND (NULL DEFAULT)
                       (EQ FILE T)
                       (SETQ TEM (FASSOC CHAR (ASKUSERLOOKUP 'MACROCHARS]
                  (READC T)
                  (SETTERMTABLE OLDTTBL)
                  (EVAL (CDR TEM))
                  (SETTERMTABLE ASKUSERTTBL)
                  (GO READLP))
                 ((AND (NULL DEFAULT)
                       (EQ CHAR '?)
                       (EQ FILE T))
                  (TERPRI T)
                  (READC T)
                  [NLSETQ (PROGN (PRIN1 (OR (fetch (OPTIONS EXPLAINSTRING) of OPTIONSLST)
                                            (CONCAT "one of:" EOL))
                                        T)
                                 (ASKUSEREXPLAIN KEYLST PRINTLST OPTIONSLST
                                        (OR (ASKUSERLOOKUP 'EXPLAINDELIMITER)
                                            EOL]
                  (TERPRI T)
                  [AND ORIGMESS (COND
                                   ((NLISTP ORIGMESS)
                                    (ASKUSERPRIN1 ORIGMESS))
                                   (T (MAPRINT ORIGMESS T NIL " ? " NIL NIL LISPXPRNTFLG]
                  [MAPC PRINTLST (FUNCTION (LAMBDA (X)
                                             (PRIN1 X T]
                  (AND (NEQ NC 1)
                       (PRIN1 (SUBSTRING [COND
                                            ((NLISTP (CAR KEYLST))
                                             (CAR KEYLST))
                                            (T (OR (fetch (ASKUSER KEYSTRING)
                                                      of (CAR KEYLST))
                                                   (fetch (ASKUSER KEY) of (CAR KEYLST]
                                     1
                                     (SUB1 NC))
                              T))

                  (* ;; "These are the characters that have been matched on this level key, but not yet added to answer or printlst.")

                  (GO READLP))
                 ([SETQ KEYLST1
                   (find X in KEYLST
                      suchthat (SELECTC X
                                       ([LIST '& (CHARACTER (CHARCODE ESCAPE))
                                              (PACKC (CHARCODE (ESCAPE ESCAPE] 
                                            (SETQ KEY X)
                                            T)
                                       (AND (LISTP X)
                                            (SELECTC (CAR X)
                                                ('& 
                                                     (COND
                                                        ((OR [NULL (SETQ TEM (LISTGET1 X 'CLASS]
                                                             (APPLY* TEM CHAR))
                                                         (SETQ KEY (CAR X))
                                                         T)))
                                                ([LIST (CHARACTER (CHARCODE ESCAPE))
                                                       (PACKC (CHARCODE (ESCAPE ESCAPE] 
                                                     (SETQ KEY (CAR X))
                                                     T)
                                                (AND (LISTP (CAR X))
                                                     (SETQ KEY (CAR X]
                  (COND
                     ((EQ KEY '&)
                      [SETQ KEYLST (LIST (CONS CHAR (AND (LISTP KEYLST1)
                                                         (CDR KEYLST1]
                      (GO RIGHT))
                     (T                                      (* ; "altmode.  or double-altmode")
                                                             (* (AND (EQ FILE T)
                                                           (PRIN1 CHAR T)))

                        (* ;; "The character would not have been echoed since the PEEKC was done with echomode off.  Since it has already been seen by LISP, it wold not be echoed by the READ below, even though ECHOMODE would then be turned on.  Therefore must print it.")

                        (SETTERMTABLE OLDTTBL)
                        (OR (PROG1 [NLSETQ (COND
                                              ([EQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                                               (SETQ TEM (READ FILE T)))
                                              [[EQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE]
                                               (LET (READBUF)
                                                    (DECLARE (SPECVARS READBUF))

                                 (* ;; "since READ is used, rather than lispxread for $ key, we should not have readline be affected by readbuf, e.g.  if user is redoing an event contaig an askuser, he wants to type in tuff again.")

                                                    (SETQ TEM (READLINE T]
                                              (T (SETQ TEM (EVAL KEY]
                                   (SETTERMTABLE ASKUSERTTBL))
                            (GO RETRY))
                        (SETQ KEYLST (LIST (create ASKUSER using (LISTP KEYLST1)
                                                                     KEY _ TEM)))
                        (SETQ NC (ADD1 (NCHARS TEM)))
                        (SETQ ECHOEDFLG T)                   (* ; 
                                   "so that the character terminatng the read wont be echoed twice")
                        [COND
                           [(SYNTAXP [SETQ TEM (CHCON1 (SETQ CHAR (LASTC FILE]
                                   'SEPR T)                  (* ; 
                                                       "character was included as part of the read")
                            (replace OPTIONS of (CAR KEYLST)
                               with (CONS 'CONFIRMFLG (CONS (LIST CHAR)
                                                                (fetch OPTIONS
                                                                   of (CAR KEYLST]
                           ((SYNTAXP TEM 'BREAK T)           (* ; "e.g.  read of a lit")
                            (GO READLP))
                           (T (SETQ CHAR (READC FILE]

                        (* ;; "(COND ((EQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE)))) (* (61  . 965) 130 <NEWLISP>ASSIST.;8 NIL) (SETQ CHAR (READC FILE))) ((EQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE))))) (SETQ CHAR (LASTC FILE)) (replace OPTIONS of (CAR KEYLST) with (CONS (QUOTE CONFIRMFLG) (CONS (QUOTE (] 
)) (fetch (ASKUSER OPTIONS) of (CAR KEYLST)))))) ((LISTP KEY) (* (73  . 955) 107 <NEWLISP>ASSIST.;30 NIL)) (T (SHOULDNT)))")

                        (SETQ DEFAULT '(T))

                        (* ;; "so wont attempt to read the character again.  reason we have to read it here, in the case of read, is that it has already been echoed, and in the case of a lower keylst, there would be no way to psass on the information about it having been echoed without setting echoedflg to T.  thus we cant go back to READLP, sice that wold set echoflg to NIL.")

                        (GO INTERP]
          WRONG
                                                             (* ; "user typed invalid answer")
              (AND (NEQ FILE T)
                   (ERROR!))
              (AND (NULL DEFAULT)
                   (READC FILE))
              (COND
                 (TYPEAHEAD (GO RETRY1)))
              (PRINTBELLS)
              (DOBE)
              (CLEARBUF T)
              (GO READLP)
          RIGHT
                                                             (* ; "character matched.")
              (AND (NULL DEFAULT)
                   (READC FILE))
          RIGHT1
              (ASKUSERSETUP (CAR KEYLST))
              (COND
                 ((OR (CDR KEYLST)
                      (ILESSP NC (NCHARS KEY)))              (* ; 
                                    "More than one candidate.  or this candidate not finished yet.")
                  (AND (NULL NOECHOFLG)
                       (EQ FILE T)
                       (SETQ TEM (COND
                                    ((SETQ TEM (ASKUSERLOOKUP 'KEYSTRING))

                                     (* ;; "primarily to allow specifying of echoing in lower case, even though askuser always converts to uppercase when it reads.")

                                     (NTHCHAR TEM NC))
                                    (T CHAR)))
                       (PRIN1 TEM T))
                  (SETQ NC (ADD1 NC))
                  [COND
                     ((AND (ASKUSERLOOKUP 'AUTOCOMPLETEFLG)
                           (SETQ TEM (ASKUSER$ KEYLST CHAR NC)))
                      (COND
                         ((AND (NULL (CDR KEYLST))
                               (EQ (SETQ NC TEM)
                                   (NCHARS KEY)))
                          (GO COMPLETED))
                         (T (SETQ NC (ADD1 TEM]
                  (GO NEXT)))                                (* ; 
                             "There is only one entry left, and all of its characters are matched.")
              (AND (NULL NOECHOFLG)
                   (EQ FILE T)
                   (EQ NC (NCHARS KEY))
                   (SETQ TEM (COND
                                ((SETQ TEM (ASKUSERLOOKUP 'KEYSTRING))
                                 (NTHCHAR TEM NC))
                                (T CHAR)))
                   (PRIN1 TEM T))

         (* ;; "the character is the last one in the key.  the case where a c.r.  was typed to terminate a key is handled below.")

          COMPLETED
              (SETQ ANSWER (NCONC1 ANSWER (OR (ASKUSERLOOKUP 'KEYSTRING)
                                              KEY)))
              [AND (NULL NOECHOFLG)
                   (SETQ PRINTLST (NCONC1 PRINTLST (OR (ASKUSERLOOKUP 'KEYSTRING)
                                                       KEY]
              [AND PROMPTSTRING (OR [NULL (SETQ TEM (ASKUSERLOOKUP 'PROMPTON]
                                    (MEMB CHAR TEM))
                   (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 PROMPTSTRING T]

         (* ;; "If PROMPTON is present, must wait till after confirmation to see if confirming charactter is PROMPTON (usually $).  this enables tenex like protocols.")

              (AND (NULL NOECHOFLG)
                   (EQ FILE T)
                   (IGREATERP NC (NCHARS KEY))
                   (PRIN1 (COND
                             ([AND (EQ CHAR EOL)
                                   (NULL (ASKUSERLOOKUP 'KEYLST]

                              (* ;; "space is echoed for all confirming characters except on a terminal leaf,in which char isused itself.")

                              CHAR)
                             (T SPACE))
                          T))
              (COND
                 ([OR (NULL CONFIRMFLG)
                      (COND
                         ((LISTP CONFIRMFLG)
                          (MEMB CHAR CONFIRMFLG))
                         (T (OR (EQ CHAR EOL)
                                (EQ CHAR SPACE]

                  (* ;; "CONFIRMFLG can be a list of characters that are acceptable for confirming.  e.g.  ($) can be used to implemente tenex like protocols.")

                  (GO CONFIRMED))
                 (T (GO CONFIRM)))
          NEXT
              (SETQ DEFAULT (CDR DEFAULT))

         (* ;; "DEFAULT stays one behind the current character so that we can tell if the character came from a default list.")

              (COND
                 ((NULL DEFAULT)
                  (GO READLP))
                 (T (SETQ CHAR (CAR DEFAULT))
                    (GO INTERP)))
              (GO INTERP)
          CONFIRM
              (COND
                 ((ASKUSERLOOKUP 'PROMPTCONFIRMFLG)
                  (PRIN1 " [confirm] " T)))
              [COND
                 ((AND (STRINGP FILE)
                       (NOT (READP FILE T)))
                  (SETQ FILE T)
                  (SETQ OLDTTBL (GETTERMTABLE))
                  (RESETSAVE (SETTERMTABLE ASKUSERTTBL]
              [SETQ CHAR (COND
                            ((SETQ DEFAULT (CDR DEFAULT))
                             (CAR DEFAULT))
                            (T (READC FILE]
              (COND
                 ((OR (SYNTAXP (SETQ TEM (CHCON1 CHAR))
                             'CHARDELETE)
                      (SYNTAXP TEM 'LINEDELETE))             (* ; "control-a or q")
                  (GO RETRY))
                 [(LISTP CONFIRMFLG)
                  (COND
                     ((MEMB CHAR CONFIRMFLG)                 (* ; "used for TENEX mode.")
                      [AND PROMPTSTRING (SETQ TEM (ASKUSERLOOKUP 'PROMPTON))
                           (MEMB CHAR TEM)
                           (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 PROMPTSTRING T]
                      (AND (NULL NOECHOFLG)
                           (PRIN1 SPACE T))
                      (GO CONFIRMED]
                 ((OR (EQ CHAR SPACE)
                      (EQ CHAR EOL))
                  [COND
                     ((NULL NOECHOFLG)
                      (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 (COND
                                                                ((NULL (ASKUSERLOOKUP
                                                                        'KEYLST))
                                                                 CHAR)
                                                                (T SPACE))
                                                             T]
                  (GO CONFIRMED))
                 ([SETQ TEM (FASSOC CHAR (ASKUSERLOOKUP 'MACROCHARS]
                  (SETTERMTABLE OLDTTBL)
                  (EVAL (CDR TEM))
                  (SETTERMTABLE ASKUSERTTBL)
                  (GO CONFIRM)))
              (COND
                 ((NEQ CHAR '?)
                  (PRIN1 (PACKC (CHARCODE (BELL ?)))
                         T)
                  (DOBE)
                  (CLEARBUF T)))
              (PRIN1 " [confirm] " T)
              (GO CONFIRM)
          CONFIRMED
              (COND
                 ((SETQ TEM (ASKUSERLOOKUP 'KEYLST))
                  (SETQ KEYLST TEM)
                  (SETQ NC 1)
                  (GO NEXT)))
              (COND
                 (LISPXPRNTFLG [MAPC PRINTLST (FUNCTION (LAMBDA (X)
                                                          (ASKUSERPRIN1 X T]
                                                             (* ; 
                                                         "fakes the printing for the history list.")
                        ))
              (COND
                 (BUFS (BKBUFS BUFS)))
              (RETURN (COND
                         [(SETQ TEM (OR (FMEMB 'RETURN OPTIONS)
                                        (FMEMB 'RETURN OPTIONSLST)))
                          (SETTERMTABLE OLDTTBL)
                          (COND
                             ([SETQ TEM (NLSETQ (EVAL (CADR TEM]

                              (* ;; "ASKUSERLOOKUP (QUOTE not) used since then couldnt distinguish case where RETURN NIL was specified from case where RETURN was not specified at all.")

                              (* ;; "This permits user to return ANSWER as a list itself, or to take some other action, and then restart by simply generateing an error.")

                              (CAR TEM))
                             (T (SETTERMTABLE ASKUSERTTBL)
                                (GO RETRY]
                         (ANSWER (PACK ANSWER))
                         (T (NOTCHECKED)
                            KEY)))
          RETRY
              (COND
                 (TYPEAHEAD (GO RETRY1)))
              (PRIN1 "___" T)
              (TERPRI T)
              (DOBE)
              (CLEARBUF T)
              (SETQ KEYLST ORIGKEYLST)
              (SETQ PRINTLST NIL)
              (SETQ NC 1)
              (SETQ ANSWER NIL)
              (GO READLP)
          RETRY1
              

         (* ;; "User has typed ahead before the call to askuser1 and his resonse is invalid.  therefore assume he didnt know that askuser would be called and his typeahead was intended for what follows.  clear and ave the typeahead and continue with interaction.")

              (LINBUF)
              (SYSBUF)
              (SETQ BUFS (CLBUFS NIL T READBUF))
              [SETQ TEM (APPLY 'CONCAT (NCONC ANSWER [AND (NEQ NC 1)
                                                          (LIST (SUBSTRING (COND
                                                                              ((LISTP (CAR KEYLST))
                                                                               (CAAR KEYLST))
                                                                              (T (CAR KEYLST)))
                                                                       1
                                                                       (SUB1 NC]
                                              (LIST CHAR]
              [COND
                 ((NULL BUFS)
                  (SETQ BUFS (CONS NIL TEM)))
                 (T (RPLACD BUFS (COND
                                    ((CDR BUFS)
                                     (CONCAT TEM (CDR BUFS)))
                                    (T TEM]
              (SETQ TYPEAHEAD NIL)                           (* ; "so this is only done once")
              (SETQ ANSWER NIL)
              (SETQ KEYLST ORIGKEYLST)
              (SETQ MESS ORIGMESS)
              (SETQ DEFAULT ORIGDEFAULT)
              (SETQ PRINTLST NIL)
              (TERPRI T)
              (GO MESS)))])

(ASKUSERLOOKUP
  [LAMBDA (FIELD)                                            (* bvm%: "26-Apr-86 17:14")
          
          (* * this wuld be just a fetch, xcept want to lok it up on optionslst if not 
          found on options.)

    (CADR (OR (FMEMB FIELD OPTIONS)
              (FMEMB FIELD OPTIONSLST])

(ASKUSERCHAR
  [LAMBDA (C1 C2)                                            (* bvm%: "26-Apr-86 17:27")
    (COND
       ((EQ C1 C2))
       ((AND (NULL NOCASEFLG)
             C2)
        (SETQ C1 (CHCON1 C1))
        (SETQ C2 (CHCON1 C2))
        (COND
           [(AND (IGEQ C1 (CHARCODE a))
                 (ILEQ C1 (CHARCODE z)))
            (EQ C2 (IDIFFERENCE C1 (IDIFFERENCE (CHARCODE a)
                                          (CHARCODE A]
           ((AND (IGEQ C2 (CHARCODE a))
                 (ILEQ C2 (CHARCODE z)))
            (EQ C1 (IDIFFERENCE C2 (IDIFFERENCE (CHARCODE a)
                                          (CHARCODE A])

(ASKUSER$
  [LAMBDA (KEYLST CHAR NC)                                   (* bvm%: "26-Apr-86 17:13")
    (for ENTRY bind NC0 KEY0 TEM in KEYLST eachtime [SETQ KEY (COND
                                                                 ((NLISTP ENTRY)
                                                                  ENTRY)
                                                                 (T (fetch (ASKUSER KEY) of ENTRY]
       when [AND [NEQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                 (NEQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE]
       do [COND
             ((NULL KEY0)                                    (* first time through)
              [SETQ KEY0 (COND
                            ((NLISTP (CAR KEYLST))
                             (CAR KEYLST))
                            (T (fetch (ASKUSER KEY) of (CAR KEYLST]
              (SETQ NC0 (NCHARS KEY0)))
             (T 
          
          (* Goes through keylst and looks at each key and determines the largest N for 
          which NTHCHAR of thatcharacter is equal for every atom.)

                (SETQ NC0 (for I from 1 to NC0 while (EQ (NTHCHARCODE KEY I)
                                                         (NTHCHARCODE KEY0 I))
                             finally (RETURN (SUB1 I]
       finally (COND
                  ((OR (NULL NC0)
                       (ILESSP NC0 NC))                      (* all atoms have different characters 
                                                             at this position.)
                   (RETURN NIL)))
             (ASKUSERSETUP (CAR KEYLST))
             [SETQ TEM (AND (OR [NULL (SETQ TEM (ASKUSERLOOKUP 'COMPLETEON]
                                (MEMB CHAR TEM))
                            (SUBSTRING (OR (ASKUSERLOOKUP 'KEYSTRING)
                                           KEY)
                                   NC
                                   (COND
                                      ((EQ (NCHARS KEY0)
                                           NC0)
          
          (* reason for this is in case KEYSTRING is longer, will get all of it.)

                                       -1)
                                      (T NC0] 
          
          (* if COMPLETEON is $ means only complete on alt-mode.
          this is used for tenex type protocol)

             (AND (NULL NOECHOFLG)
                  TEM
                  (PRIN1 TEM T)) 
          
          (* Reason for not just using value of noechoflg is that askusersetup oul have 
          set noechoflg to T when reading from a string in order to suppress echoing of 
          the character, but this does not mean that we do not echo the characters that 
          are supplied for copleting.)

             (RETURN NC0])

(ASKUSER1
  [LAMBDA (ENTRY CHAR)                                       (* DD%: "26-Oct-81 12:34")
          
          (* We know that ENTRY contains a subkeylst.
          This function sees if char could conceivably match one of the entries on 
          keylst.)

    (thereis ENTRY bind TEM in (fetch (ASKUSER KEYLST) of ENTRY)
       eachtime [SETQ TEM (COND
                             ((NLISTP ENTRY)
                              ENTRY)
                             (T (fetch (ASKUSER KEY) of ENTRY]
       suchthat (OR (EQ TEM '&)
                    [EQ TEM (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                    [EQ TEM (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE]
                    (LISTP TEM)
                    (EQ (SETQ TEM (NTHCHAR TEM 1))
                        CHAR)
                    (AND (NULL TEM)
                         (LISTP ENTRY)
                         (LISTP (CDR ENTRY))
                         (ASKUSER1 ENTRY CHAR])

(ASKUSERSETUP
  [LAMBDA (ENTRY)                                            (* bvm%: "26-Apr-86 17:13")
                                                             (* Sets free variables KEY, 
                                                             CONFIRMFLG, QUIETFLG, and PROMPTSTRING)
    (PROG (TEM)
          [COND
             [(NLISTP ENTRY)
              (SETQ KEY ENTRY)
              (SETQ PROMPTSTRING NIL)
              (SETQ OPTIONS NIL)
          
          (* The default is for NOECHOFLG to be NIL and CONFIRMFLG to be T.)

              (SETQ CONFIRMFLG (COND
                                  ((SETQ TEM (MEMB 'CONFIRMFLG OPTIONSLST))
                                   (CADR TEM))
                                  (T T]
             [(NLISTP (CDR ENTRY))
              (SETQ KEY (CAR ENTRY))
              (SETQ PROMPTSTRING (CDR ENTRY))
              (SETQ OPTIONS NIL)
              (SETQ CONFIRMFLG (COND
                                  ((SETQ TEM (MEMB 'CONFIRMFLG OPTIONSLST))
                                   (CADR TEM))
                                  (T T]
             (T (SETQ KEY (fetch (ASKUSER KEY) of ENTRY))
                (SETQ PROMPTSTRING (fetch (ASKUSER PROMPTSTRING) of ENTRY))
                (SETQ OPTIONS (fetch (ASKUSER OPTIONS) of ENTRY))
                (SETQ CONFIRMFLG (ASKUSERLOOKUP 'CONFIRMFLG]
          (SETQ NOECHOFLG (ASKUSERLOOKUP 'NOECHOFLG))
          (SETQ NOCASEFLG (ASKUSERLOOKUP 'NOCASEFLG))
          (AND ECHOEDFLG (SETQ NOECHOFLG T))
          (COND
             ((AND (NEQ FILE T)
                   (STRINGP FILE)
                   (READP FILE T))
              (SETQ NOECHOFLG T)
              (SETQ PROMPTSTRING NIL)
          
          (* askusersetup is called after the character has been read.
          Thus, this sets noechoflg to T and promptstring to NIL only if there are more 
          characters to be read. However, the check on whether or not the character JUST 
          read is to bechoed alsoincludes an (EQ FILE T) check)

              ])

(ASKUSEREXPLAIN
  [LAMBDA (KEYLST PREV OPTIONSLST DELIMITER)                 (* bvm%: "26-Apr-86 17:13")
    (MAPC KEYLST (FUNCTION (LAMBDA (ENTRY)
                             (PROG (KEY CONFIRMFLG NOECHOFLG PROMPTSTRING TEM OPTIONS (FILE T))
                                   (ASKUSERSETUP ENTRY)
                                   (COND
                                      ((SETQ TEM (ASKUSERLOOKUP 'KEYLST))
                                                             (* entry is of the form
                                                             (key prompt charlst))
                                       (ASKUSEREXPLAIN
                                        TEM
                                        [COND
                                           ((SETQ TEM (fetch (OPTIONS EXPLAINSTRING) of OPTIONS))
          
          (* reason for not using askuserlookup is that don't want top level 
          explainstring on ptionslst, if any. doesnt make sense to print it each time.
          it is printed only once.)

                                            (APPEND PREV (LIST TEM)))
                                           (T (APPEND PREV (AND (NULL NOECHOFLG)
                                                                (LIST (OR (ASKUSERLOOKUP 'KEYSTRING)
                                                                          KEY)))
                                                     (AND PROMPTSTRING (LIST PROMPTSTRING]
                                        OPTIONSLST DELIMITER)
                                       (RETURN)))
                                   [MAPC PREV (FUNCTION (LAMBDA (X)
                                                          (COND
                                                             ((LISTP X)
                                                              (MAPRINT X T))
                                                             (T (PRIN1 X T]
                                   [COND
                                      [(SETQ TEM (fetch (OPTIONS EXPLAINSTRING) of OPTIONS))
                                       (COND
                                          ((LISTP TEM)
                                           (MAPRINT TEM T))
                                          (T (PRIN1 TEM T]
                                      ((SETQ TEM (OR (ASKUSERLOOKUP 'KEYSTRING)
                                                     KEY))
                                       (AND (NULL NOECHOFLG)
                                            [NEQ TEM (CONSTANT (CHARACTER (CHARCODE ESCAPE]
                                            (NEQ TEM '&)
                                            (PRIN1 TEM T))
          
          (* If the user wants to explain the & or $, he can include the appropriate text 
          in the prompt field.)

                                       (AND PROMPTSTRING (PRIN1 PROMPTSTRING T]
                                   (AND (NEQ (POSITION T)
                                             0)
                                        (PRIN1 DELIMITER T))
                                   (RETURN])

(ASKUSERPRIN1
  [LAMBDA (X NODOFLG)                                        (* wt%: % 4-DEC-75 00%:39)
          
          (* does a lispxprin1 if lispxprntflg is non-NIL.
          used to be done by having everythin printed with lispxprin1 and doing a 
          resetsave on lisxpprintflg, but this costs several conses each call.)

    (COND
       ((NULL LISPXPRNTFLG)
        (OR NODOFLG (PRIN1 X T)))
       (T (LISPXPRIN1 X T NIL NODOFLG)))
    X])

(MAKEKEYLST
  [LAMBDA (LST DEFAULTKEY LCASFLG AUTOCOMPLETEFLG)           (* wt%: "14-NOV-78 02:03")
    (PROG (TEM)
          (RETURN (NCONC [SETQ TEM (MAPCAR LST (FUNCTION (LAMBDA (KEY)
                                                           (LIST
                                                            KEY NIL 'KEYSTRING
                                                            (CONCAT (COND
                                                                       ((AND LCASFLG
                                                                             (EQUAL KEY (U-CASE
                                                                                         KEY)))
                                                             (* when ucasep gets in system, use it 
                                                             instead)
                                                                        (L-CASE KEY))
                                                                       (T KEY))
                                                                   " ")
                                                            'CONFIRMFLG T 'AUTOCOMPLETEFLG 
                                                            AUTOCOMPLETEFLG 'RETURN (KWOTE KEY]
                         [for X in TEM bind KEYSTRING as I from 1
                            collect (SETQ KEYSTRING (LISTGET X 'KEYSTRING))
                                  (LIST I KEYSTRING 'NOECHOFLG T 'EXPLAINSTRING (CONCAT I " - " 
                                                                                       KEYSTRING)
                                        'CONFIRMFLG T 'RETURN (LIST 'PROGN '(TERPRI T)
                                                                    (KWOTE (CAR X]
                         (COND
                            [(NULL DEFAULTKEY)
                             (LIST '("No - none of the above " "" CONFIRMFLG T AUTOCOMPLETEFLG T 
                                           RETURN NIL]
                            ((LISTP DEFAULTKEY)
          
          (* so user can specify no default key by simply calling with defaultkey=T)

                             (LIST DEFAULTKEY])
)



(* ;; "RMK: Avoid literal CR's on files.")


(RPAQ? DEFAULTKEYLST [LIST [LIST 'Y (CONCAT "es" (CHARACTER (CHARCODE EOL]
                               (LIST 'N (CONCAT "o" (CHARACTER (CHARCODE EOL])

(RPAQ? ASKUSERTTBL (COPYTERMTABLE))
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(CONTROL T ASKUSERTTBL)

(ECHOMODE NIL ASKUSERTTBL)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD ASKUSER (KEY PROMPTSTRING . OPTIONS)
                    (SYSTEM))

(PROPRECORD OPTIONS (KEYLST CONFIRMFLG RETURN EXPLAINSTRING NOECHOFLG KEYSTRING PROMPTON 
                               COMPLETEON AUTOCOMPLETEFLG MACROCHARS NOCASEFLG PROMPTCONFIRMFLG CLASS
                               )
                        (SYSTEM))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DEFAULTKEYLST ASKUSERTTBL)
)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS ASKUSER COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 2020 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1373 49970 (ASKUSER 1383 . 36970) (ASKUSERLOOKUP 36972 . 37300) (ASKUSERCHAR 37302 . 
37961) (ASKUSER$ 37963 . 40871) (ASKUSER1 40873 . 41904) (ASKUSERSETUP 41906 . 44035) (ASKUSEREXPLAIN 
44037 . 47232) (ASKUSERPRIN1 47234 . 47710) (MAKEKEYLST 47712 . 49968)))))
STOP
\ No newline at end of file
diff --git a/sources/ASKUSER.LCOM b/sources/ASKUSER.LCOM
index 3592900e..9420aa8e 100644
Binary files a/sources/ASKUSER.LCOM and b/sources/ASKUSER.LCOM differ
diff --git a/sources/ATBL b/sources/ATBL
index 9cb0cf49..f5862949 100644
--- a/sources/ATBL
+++ b/sources/ATBL
@@ -1 +1 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "20-Apr-2018 17:35:56" {DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ATBL.;7 256555Q

      changes to%:  (VARS ATBLCOMS)
                    (FNS \ATBLSET)

      previous date%: "20-Apr-2018 16:53:30" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>sources>ATBL.;6)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1993, 2018 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ATBLCOMS)

(RPAQQ ATBLCOMS
       [(E (RESETSAVE (RADIX 8)))
        (COMS                                                (* ; 
                                                      "Common features of read and terminal tables")
              (DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE)
                                         (RECORDS CHARTABLE))
                     (CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
                     (MACROS \CREATENSCHARHASH))
              (FNS GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE \MAPCHARTABLE)
              )
        (COMS                                                (* ; "terminal tables")
              (FNS CONTROL COPYTERMTABLE DELETECONTROL GETDELETECONTROL ECHOCHAR ECHOCONTROL ECHOMODE
                   GETECHOMODE GETCONTROL GETTERMTABLE RAISE GETRAISE RESETTERMTABLE SETTERMTABLE 
                   TERMTABLEP \GETTERMSYNTAX \GTTERMTABLE \ORIGTERMTABLE \SETTERMSYNTAX 
                   \TERMCLASSTOCODE \TERMCODETOCLASS \LITCHECK)
              (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * CCECHOMODES)
                                         (CONSTANTS * TERMCLASSES)
                                         (RECORDS TERMCODE TERMTABLEP)))
              (INITRECORDS TERMTABLEP))
        (COMS                                                (* ; "read tables")
              (FNS COPYREADTABLE FIND-READTABLE IN-READTABLE ESCAPE GETBRK GETREADTABLE GETSEPR 
                   READMACROS READTABLEP READTABLEPROP RESETREADTABLE SETBRK SETREADTABLE SETSEPR 
                   \GETREADSYNTAX \GTREADTABLE \GTREADTABLE1 \ORIGREADTABLE \READCLASSTOCODE 
                   \SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT)
              (PROP ARGNAMES READTABLEPROP)
              (DECLARE%: EVAL@COMPILE DONTCOPY               (* ; 
                             "READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
                                                             (* ; 
                                                    "OTHER must be zero because of initialization.")
                     [VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS
                                                               (FUNCTION (LAMBDA
                                                                          (PAIR)
                                                                          (LIST (PACK* (CAR PAIR)
                                                                                       ".RC")
                                                                                (CADR PAIR]
                     (MACROS \COMPUTED.FORM)
                                                             (* ; 
                                                          "This macro ought to be official somehow")
                     (RECORDS CONTEXTS ESCAPES WAKEUPS)
                     (EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1)
                            (CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
                            (CONSTANTS * READCODEMASKS)
                            (CONSTANTS * READMACROCONTEXTS)
                            (CONSTANTS * READCLASSES)
                            (CONSTANTS * READMACROWAKEUPS)
                            (CONSTANTS * READMACROESCAPES)
                            (RECORDS READCODE READMACRODEF READTABLEP))
                     (GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE))
              (INITRECORDS READTABLEP))
        [COMS (INITVARS (\READTABLEHASH))
              (FNS \ATBLSET)
              (INITRECORDS READER-ENVIRONMENT)
                                                             (* ; 
            "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
              (FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT)
              (INITVARS (*LISP-PACKAGE*)
                     (*INTERLISP-PACKAGE*)
                     (*KEYWORD-PACKAGE*))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\ATBLSET]
        (LOCALVARS . T)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA READTABLEPROP])



(* ; "Common features of read and terminal tables")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR)
                                    (CHECK (type? CHARTABLE TABLE))
                                                             (* ; 
                                                       "0 is either NONE.TC, REAL.CCE, or OTHER.RC")
                                    (COND
                                       ((IGREATERP CHAR \MAXTHINCHAR)
                                        (OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
                                                 (GETHASH CHAR (fetch (CHARTABLE NSCHARHASH)
                                                                  of TABLE)))
                                            0))
                                       (T (\GETBASEBYTE TABLE CHAR])

(PUTPROPS \SETSYNCODE DMACRO [LAMBDA (TABLE CHAR CODE)
                                       (CHECK (type? CHARTABLE TABLE))
                                                             (* ; 
                                                           "0 is REAL.CCE, NONE.TC, OTHER.RC")
                                       (COND
                                          ((ILEQ CHAR \MAXTHINCHAR)
                                           (\PUTBASEBYTE TABLE CHAR CODE))
                                          (T (\SETFATSYNCODE TABLE CHAR CODE])
)
(DECLARE%: EVAL@COMPILE

(DATATYPE CHARTABLE ((CHARSET0 400Q BYTE)
                         (NSCHARHASH FULLPOINTER)))
)

(/DECLAREDATATYPE 'CHARTABLE
       '(BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              FULLPOINTER)
       '((CHARTABLE 0 (BITS . 7))
         (CHARTABLE 0 (BITS . 207Q))
         (CHARTABLE 1 (BITS . 7))
         (CHARTABLE 1 (BITS . 207Q))
         (CHARTABLE 2 (BITS . 7))
         (CHARTABLE 2 (BITS . 207Q))
         (CHARTABLE 3 (BITS . 7))
         (CHARTABLE 3 (BITS . 207Q))
         (CHARTABLE 4 (BITS . 7))
         (CHARTABLE 4 (BITS . 207Q))
         (CHARTABLE 5 (BITS . 7))
         (CHARTABLE 5 (BITS . 207Q))
         (CHARTABLE 6 (BITS . 7))
         (CHARTABLE 6 (BITS . 207Q))
         (CHARTABLE 7 (BITS . 7))
         (CHARTABLE 7 (BITS . 207Q))
         (CHARTABLE 10Q (BITS . 7))
         (CHARTABLE 10Q (BITS . 207Q))
         (CHARTABLE 11Q (BITS . 7))
         (CHARTABLE 11Q (BITS . 207Q))
         (CHARTABLE 12Q (BITS . 7))
         (CHARTABLE 12Q (BITS . 207Q))
         (CHARTABLE 13Q (BITS . 7))
         (CHARTABLE 13Q (BITS . 207Q))
         (CHARTABLE 14Q (BITS . 7))
         (CHARTABLE 14Q (BITS . 207Q))
         (CHARTABLE 15Q (BITS . 7))
         (CHARTABLE 15Q (BITS . 207Q))
         (CHARTABLE 16Q (BITS . 7))
         (CHARTABLE 16Q (BITS . 207Q))
         (CHARTABLE 17Q (BITS . 7))
         (CHARTABLE 17Q (BITS . 207Q))
         (CHARTABLE 20Q (BITS . 7))
         (CHARTABLE 20Q (BITS . 207Q))
         (CHARTABLE 21Q (BITS . 7))
         (CHARTABLE 21Q (BITS . 207Q))
         (CHARTABLE 22Q (BITS . 7))
         (CHARTABLE 22Q (BITS . 207Q))
         (CHARTABLE 23Q (BITS . 7))
         (CHARTABLE 23Q (BITS . 207Q))
         (CHARTABLE 24Q (BITS . 7))
         (CHARTABLE 24Q (BITS . 207Q))
         (CHARTABLE 25Q (BITS . 7))
         (CHARTABLE 25Q (BITS . 207Q))
         (CHARTABLE 26Q (BITS . 7))
         (CHARTABLE 26Q (BITS . 207Q))
         (CHARTABLE 27Q (BITS . 7))
         (CHARTABLE 27Q (BITS . 207Q))
         (CHARTABLE 30Q (BITS . 7))
         (CHARTABLE 30Q (BITS . 207Q))
         (CHARTABLE 31Q (BITS . 7))
         (CHARTABLE 31Q (BITS . 207Q))
         (CHARTABLE 32Q (BITS . 7))
         (CHARTABLE 32Q (BITS . 207Q))
         (CHARTABLE 33Q (BITS . 7))
         (CHARTABLE 33Q (BITS . 207Q))
         (CHARTABLE 34Q (BITS . 7))
         (CHARTABLE 34Q (BITS . 207Q))
         (CHARTABLE 35Q (BITS . 7))
         (CHARTABLE 35Q (BITS . 207Q))
         (CHARTABLE 36Q (BITS . 7))
         (CHARTABLE 36Q (BITS . 207Q))
         (CHARTABLE 37Q (BITS . 7))
         (CHARTABLE 37Q (BITS . 207Q))
         (CHARTABLE 40Q (BITS . 7))
         (CHARTABLE 40Q (BITS . 207Q))
         (CHARTABLE 41Q (BITS . 7))
         (CHARTABLE 41Q (BITS . 207Q))
         (CHARTABLE 42Q (BITS . 7))
         (CHARTABLE 42Q (BITS . 207Q))
         (CHARTABLE 43Q (BITS . 7))
         (CHARTABLE 43Q (BITS . 207Q))
         (CHARTABLE 44Q (BITS . 7))
         (CHARTABLE 44Q (BITS . 207Q))
         (CHARTABLE 45Q (BITS . 7))
         (CHARTABLE 45Q (BITS . 207Q))
         (CHARTABLE 46Q (BITS . 7))
         (CHARTABLE 46Q (BITS . 207Q))
         (CHARTABLE 47Q (BITS . 7))
         (CHARTABLE 47Q (BITS . 207Q))
         (CHARTABLE 50Q (BITS . 7))
         (CHARTABLE 50Q (BITS . 207Q))
         (CHARTABLE 51Q (BITS . 7))
         (CHARTABLE 51Q (BITS . 207Q))
         (CHARTABLE 52Q (BITS . 7))
         (CHARTABLE 52Q (BITS . 207Q))
         (CHARTABLE 53Q (BITS . 7))
         (CHARTABLE 53Q (BITS . 207Q))
         (CHARTABLE 54Q (BITS . 7))
         (CHARTABLE 54Q (BITS . 207Q))
         (CHARTABLE 55Q (BITS . 7))
         (CHARTABLE 55Q (BITS . 207Q))
         (CHARTABLE 56Q (BITS . 7))
         (CHARTABLE 56Q (BITS . 207Q))
         (CHARTABLE 57Q (BITS . 7))
         (CHARTABLE 57Q (BITS . 207Q))
         (CHARTABLE 60Q (BITS . 7))
         (CHARTABLE 60Q (BITS . 207Q))
         (CHARTABLE 61Q (BITS . 7))
         (CHARTABLE 61Q (BITS . 207Q))
         (CHARTABLE 62Q (BITS . 7))
         (CHARTABLE 62Q (BITS . 207Q))
         (CHARTABLE 63Q (BITS . 7))
         (CHARTABLE 63Q (BITS . 207Q))
         (CHARTABLE 64Q (BITS . 7))
         (CHARTABLE 64Q (BITS . 207Q))
         (CHARTABLE 65Q (BITS . 7))
         (CHARTABLE 65Q (BITS . 207Q))
         (CHARTABLE 66Q (BITS . 7))
         (CHARTABLE 66Q (BITS . 207Q))
         (CHARTABLE 67Q (BITS . 7))
         (CHARTABLE 67Q (BITS . 207Q))
         (CHARTABLE 70Q (BITS . 7))
         (CHARTABLE 70Q (BITS . 207Q))
         (CHARTABLE 71Q (BITS . 7))
         (CHARTABLE 71Q (BITS . 207Q))
         (CHARTABLE 72Q (BITS . 7))
         (CHARTABLE 72Q (BITS . 207Q))
         (CHARTABLE 73Q (BITS . 7))
         (CHARTABLE 73Q (BITS . 207Q))
         (CHARTABLE 74Q (BITS . 7))
         (CHARTABLE 74Q (BITS . 207Q))
         (CHARTABLE 75Q (BITS . 7))
         (CHARTABLE 75Q (BITS . 207Q))
         (CHARTABLE 76Q (BITS . 7))
         (CHARTABLE 76Q (BITS . 207Q))
         (CHARTABLE 77Q (BITS . 7))
         (CHARTABLE 77Q (BITS . 207Q))
         (CHARTABLE 100Q (BITS . 7))
         (CHARTABLE 100Q (BITS . 207Q))
         (CHARTABLE 101Q (BITS . 7))
         (CHARTABLE 101Q (BITS . 207Q))
         (CHARTABLE 102Q (BITS . 7))
         (CHARTABLE 102Q (BITS . 207Q))
         (CHARTABLE 103Q (BITS . 7))
         (CHARTABLE 103Q (BITS . 207Q))
         (CHARTABLE 104Q (BITS . 7))
         (CHARTABLE 104Q (BITS . 207Q))
         (CHARTABLE 105Q (BITS . 7))
         (CHARTABLE 105Q (BITS . 207Q))
         (CHARTABLE 106Q (BITS . 7))
         (CHARTABLE 106Q (BITS . 207Q))
         (CHARTABLE 107Q (BITS . 7))
         (CHARTABLE 107Q (BITS . 207Q))
         (CHARTABLE 110Q (BITS . 7))
         (CHARTABLE 110Q (BITS . 207Q))
         (CHARTABLE 111Q (BITS . 7))
         (CHARTABLE 111Q (BITS . 207Q))
         (CHARTABLE 112Q (BITS . 7))
         (CHARTABLE 112Q (BITS . 207Q))
         (CHARTABLE 113Q (BITS . 7))
         (CHARTABLE 113Q (BITS . 207Q))
         (CHARTABLE 114Q (BITS . 7))
         (CHARTABLE 114Q (BITS . 207Q))
         (CHARTABLE 115Q (BITS . 7))
         (CHARTABLE 115Q (BITS . 207Q))
         (CHARTABLE 116Q (BITS . 7))
         (CHARTABLE 116Q (BITS . 207Q))
         (CHARTABLE 117Q (BITS . 7))
         (CHARTABLE 117Q (BITS . 207Q))
         (CHARTABLE 120Q (BITS . 7))
         (CHARTABLE 120Q (BITS . 207Q))
         (CHARTABLE 121Q (BITS . 7))
         (CHARTABLE 121Q (BITS . 207Q))
         (CHARTABLE 122Q (BITS . 7))
         (CHARTABLE 122Q (BITS . 207Q))
         (CHARTABLE 123Q (BITS . 7))
         (CHARTABLE 123Q (BITS . 207Q))
         (CHARTABLE 124Q (BITS . 7))
         (CHARTABLE 124Q (BITS . 207Q))
         (CHARTABLE 125Q (BITS . 7))
         (CHARTABLE 125Q (BITS . 207Q))
         (CHARTABLE 126Q (BITS . 7))
         (CHARTABLE 126Q (BITS . 207Q))
         (CHARTABLE 127Q (BITS . 7))
         (CHARTABLE 127Q (BITS . 207Q))
         (CHARTABLE 130Q (BITS . 7))
         (CHARTABLE 130Q (BITS . 207Q))
         (CHARTABLE 131Q (BITS . 7))
         (CHARTABLE 131Q (BITS . 207Q))
         (CHARTABLE 132Q (BITS . 7))
         (CHARTABLE 132Q (BITS . 207Q))
         (CHARTABLE 133Q (BITS . 7))
         (CHARTABLE 133Q (BITS . 207Q))
         (CHARTABLE 134Q (BITS . 7))
         (CHARTABLE 134Q (BITS . 207Q))
         (CHARTABLE 135Q (BITS . 7))
         (CHARTABLE 135Q (BITS . 207Q))
         (CHARTABLE 136Q (BITS . 7))
         (CHARTABLE 136Q (BITS . 207Q))
         (CHARTABLE 137Q (BITS . 7))
         (CHARTABLE 137Q (BITS . 207Q))
         (CHARTABLE 140Q (BITS . 7))
         (CHARTABLE 140Q (BITS . 207Q))
         (CHARTABLE 141Q (BITS . 7))
         (CHARTABLE 141Q (BITS . 207Q))
         (CHARTABLE 142Q (BITS . 7))
         (CHARTABLE 142Q (BITS . 207Q))
         (CHARTABLE 143Q (BITS . 7))
         (CHARTABLE 143Q (BITS . 207Q))
         (CHARTABLE 144Q (BITS . 7))
         (CHARTABLE 144Q (BITS . 207Q))
         (CHARTABLE 145Q (BITS . 7))
         (CHARTABLE 145Q (BITS . 207Q))
         (CHARTABLE 146Q (BITS . 7))
         (CHARTABLE 146Q (BITS . 207Q))
         (CHARTABLE 147Q (BITS . 7))
         (CHARTABLE 147Q (BITS . 207Q))
         (CHARTABLE 150Q (BITS . 7))
         (CHARTABLE 150Q (BITS . 207Q))
         (CHARTABLE 151Q (BITS . 7))
         (CHARTABLE 151Q (BITS . 207Q))
         (CHARTABLE 152Q (BITS . 7))
         (CHARTABLE 152Q (BITS . 207Q))
         (CHARTABLE 153Q (BITS . 7))
         (CHARTABLE 153Q (BITS . 207Q))
         (CHARTABLE 154Q (BITS . 7))
         (CHARTABLE 154Q (BITS . 207Q))
         (CHARTABLE 155Q (BITS . 7))
         (CHARTABLE 155Q (BITS . 207Q))
         (CHARTABLE 156Q (BITS . 7))
         (CHARTABLE 156Q (BITS . 207Q))
         (CHARTABLE 157Q (BITS . 7))
         (CHARTABLE 157Q (BITS . 207Q))
         (CHARTABLE 160Q (BITS . 7))
         (CHARTABLE 160Q (BITS . 207Q))
         (CHARTABLE 161Q (BITS . 7))
         (CHARTABLE 161Q (BITS . 207Q))
         (CHARTABLE 162Q (BITS . 7))
         (CHARTABLE 162Q (BITS . 207Q))
         (CHARTABLE 163Q (BITS . 7))
         (CHARTABLE 163Q (BITS . 207Q))
         (CHARTABLE 164Q (BITS . 7))
         (CHARTABLE 164Q (BITS . 207Q))
         (CHARTABLE 165Q (BITS . 7))
         (CHARTABLE 165Q (BITS . 207Q))
         (CHARTABLE 166Q (BITS . 7))
         (CHARTABLE 166Q (BITS . 207Q))
         (CHARTABLE 167Q (BITS . 7))
         (CHARTABLE 167Q (BITS . 207Q))
         (CHARTABLE 170Q (BITS . 7))
         (CHARTABLE 170Q (BITS . 207Q))
         (CHARTABLE 171Q (BITS . 7))
         (CHARTABLE 171Q (BITS . 207Q))
         (CHARTABLE 172Q (BITS . 7))
         (CHARTABLE 172Q (BITS . 207Q))
         (CHARTABLE 173Q (BITS . 7))
         (CHARTABLE 173Q (BITS . 207Q))
         (CHARTABLE 174Q (BITS . 7))
         (CHARTABLE 174Q (BITS . 207Q))
         (CHARTABLE 175Q (BITS . 7))
         (CHARTABLE 175Q (BITS . 207Q))
         (CHARTABLE 176Q (BITS . 7))
         (CHARTABLE 176Q (BITS . 207Q))
         (CHARTABLE 177Q (BITS . 7))
         (CHARTABLE 177Q (BITS . 207Q))
         (CHARTABLE 200Q FULLPOINTER))
       '202Q)

(* "END EXPORTED DEFINITIONS")


(DECLARE%: EVAL@COMPILE 

(RPAQQ \NSCHARHASHKEYS 12Q)

(RPAQQ \NSCHARHASHOVERFLOW 1.3)


(CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \CREATENSCHARHASH  MACRO
   (ARGS                                                     (* ; 
                        "added size argument for creation of \ORIGTERMTABLE during initialization.")
         (LIST 'HASHARRAY (OR (CAR ARGS)
                              '\NSCHARHASHKEYS)
               '\NSCHARHASHOVERFLOW)))
)
)
(DEFINEQ

(GETSYNTAX
  [LAMBDA (CH TABLE)                                         (* bvm%: " 8-Mar-86 17:22")
    (COND
       [(FIXP (SETQ CH (\GETCHARCODE CH)))
        (COND
           ((type? TERMTABLEP TABLE)
            (\GETTERMSYNTAX CH TABLE))
           (T (\GETREADSYNTAX CH (\GTREADTABLE TABLE T]
       (T (PROG (TEM CHARTBL RESULT)
                (COND
                   ((SETQ TEM (\READCLASSTOCODE CH))
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM VAL)
                                                   (push RESULT KEY]
                           CHARTBL))
                   ((EQ CH 'BREAK)
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((fetch BREAK of VAL)
                                                   (push RESULT KEY]
                           CHARTBL))
                   ((SETQ TEM (\TERMCLASSTOCODE CH))
                    (SETQ CHARTBL (fetch TERMSA of (\GTTERMTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM (fetch TERMCLASS of VAL))
                                                   (push RESULT (PROG1 KEY 
                                                             (* SELECTC TEM ((LIST NONE.TC 
                                                             WORDSEPR.TC) (* ; 
                                                           "Only these classes have multiple members") 
                                                             KEY) (RETURN (CONS KEY)))]
                           CHARTBL))
                   [(FMEMB CH '(MACRO SPLICE INFIX))
                    (PROG [LST (A (fetch READMACRODEFS of (\GTREADTABLE TABLE T]
                          (COND
                             (A [MAPHASH A (FUNCTION (LAMBDA (DEF C)
                                                       (AND (EQ CH (fetch MACROTYPE of DEF))
                                                            (push LST C]
                                (RETURN LST]
                   ((SETQ TEM (fetch (CONTEXTS VAL) of CH))
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM (fetch MACROCONTEXT of VAL))
                                                   (push RESULT KEY]
                           CHARTBL))
                   ((SETQ TEM (fetch (WAKEUPS VAL) of CH))
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM (fetch WAKEUP of VAL))
                                                   (push RESULT KEY]
                           CHARTBL))
                   ((SETQ TEM (fetch (ESCAPES VAL) of CH))
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM (fetch ESCAPE of VAL))
                                                   (push RESULT KEY]
                           CHARTBL))
                   (T (\ILLEGAL.ARG CH)))
                (RETURN RESULT])

(SETSYNTAX
  [LAMBDA (CHAR CLASS TBL)                                   (* rmk%: "20-Nov-84 15:47")
    (OR (FIXP (SETQ CHAR (\GETCHARCODE CHAR)))
        (\ILLEGAL.ARG CHAR))
    [OR (type? READTABLEP TBL)
        (type? TERMTABLEP TBL)
        (SETQ TBL (COND
                     ((OR (type? TERMTABLEP CLASS)
                          (\TERMCLASSTOCODE CLASS))
                      (\GTTERMTABLE TBL))
                     (T (\GTREADTABLE TBL]
    [COND
       ((OR (type? READTABLEP CLASS)
            (type? TERMTABLEP CLASS)
            (SELECTQ CLASS
                ((NIL T ORIG) 
                     T)
                NIL))
        (SETQ CLASS (GETSYNTAX CHAR CLASS)))
       ((FIXP (SETQ CLASS (\GETCHARCODE CLASS)))
        (SETQ CLASS (GETSYNTAX CLASS TBL]
    (COND
       ((type? READTABLEP TBL)
        (PROG1 (\GETREADSYNTAX CHAR TBL)
               (\SETREADSYNTAX CHAR CLASS TBL)))
       (T (PROG1 (\GETTERMSYNTAX CHAR TBL)
                 (\SETTERMSYNTAX CHAR CLASS TBL])

(SYNTAXP
  [LAMBDA (CODE CLASS TABLE)                                 (* rmk%: " 5-JUN-80 22:40")
    (PROG (D)
          (RETURN (COND
                     ((EQ CLASS 'BREAK)
                      (fetch BREAK of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                             CODE)))
                     ((SETQ D (\READCLASSTOCODE CLASS))
                      (EQ D (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                   CODE)))
                     [(SETQ D (\TERMCLASSTOCODE CLASS))
                      (EQ D (fetch TERMCLASS of (\SYNCODE (fetch TERMSA of (\GTTERMTABLE TABLE))
                                                       CODE]
                     [(FMEMB CLASS '(MACRO SPLICE INFIX))
                      (AND (SETQ D (fetch READMACRODEFS of (\GTREADTABLE TABLE)))
                           (EQ CLASS (fetch MACROTYPE of (GETHASH CODE D]
                     [(SETQ D (fetch (CONTEXTS VAL) of CLASS))
                      (EQ D (fetch MACROCONTEXT of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                                          CODE]
                     [(SETQ D (fetch (WAKEUPS VAL) of CLASS))
                      (EQ D (fetch WAKEUP of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                                    CODE]
                     [(SETQ D (fetch (ESCAPES VAL) of CLASS))
                      (EQ D (fetch ESCAPE of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                                    CODE]
                     (T (\ILLEGAL.ARG CLASS])

(\COPYSYNTAX
  [LAMBDA (A B)                                              (* gbn "15-Sep-85 22:36")
          
          (* ;; "Copies chartable A into chartable B")

    (CHECK (AND (type? CHARTABLE A)
                (type? CHARTABLE B)))
    (\MOVEBYTES A 0 B 0 (ADD1 \MAXTHINCHAR))
    (COND
       ((fetch (CHARTABLE NSCHARHASH) of A)
        (replace (CHARTABLE NSCHARHASH) of B with (REHASH (fetch (CHARTABLE NSCHARHASH) of A)
                                                         (\CREATENSCHARHASH])

(\GETCHARCODE
  [LAMBDA (C)                                                (* rmk%: "20-Nov-84 15:46")
    (COND
       ((AND (NUMBERP C)
             (\CHARCODEP (FIX C)))
        (FIX C))
       ((AND (LITATOM C)
             (EQ 1 (NCHARS C)))
        (CHCON1 C))
       (T C])

(\SETFATSYNCODE
  [LAMBDA (TABLE CHAR CODE)                                  (* bvm%: " 8-Mar-86 17:03")

(* ;;; "Called by \SETSYNCODE macro for fat characters")

    (SETQ TABLE (\DTEST TABLE 'CHARTABLE))                   (* ; 
                                                            "CODE = 0 is REAL.CCE, NONE.TC, OTHER.RC")
    (COND
       ((ILEQ CHAR \MAXTHINCHAR)
        (\PUTBASEBYTE TABLE CHAR CODE))
       ((EQ 0 CODE)
        (COND
           ((fetch (CHARTABLE NSCHARHASH) of TABLE)          (* ; 
                                                "there was already a table here so record the change")
            (PUTHASH CHAR CODE (fetch (CHARTABLE NSCHARHASH) of TABLE)))
           (T                                                (* ; 
               "No hashtable yet, and only the default is being stored, so don't build the hashtable")
              0)))
       (T (PUTHASH CHAR CODE (OR (fetch (CHARTABLE NSCHARHASH) of TABLE)
                                 (replace (CHARTABLE NSCHARHASH) of TABLE with (\CREATENSCHARHASH])

(\MAPCHARTABLE
  [LAMBDA (FN CHARTBL)                                  (* ; "Edited 20-Apr-2018 16:53 by rmk:")
    (for I from 0 to \MAXTHINCHAR do (APPLY* FN (\GETBASEBYTE CHARTBL I)
                                                            I))
    (COND
       ((fetch (CHARTABLE NSCHARHASH) of CHARTBL)
        (MAPHASH (fetch (CHARTABLE NSCHARHASH) of CHARTBL)
               FN])
)



(* ; "terminal tables")

(DEFINEQ

(CONTROL
  [LAMBDA (MODE TTBL)                                        (* rmk%: " 8-FEB-80 11:59")
    (PROG1 (fetch CONTROLFLG of (SETQ TTBL (\GTTERMTABLE TTBL)))
           (replace CONTROLFLG of TTBL with (AND MODE T])

(COPYTERMTABLE
  [LAMBDA (TTBL)                                             (* lmm "14-APR-81 14:27")
    (create TERMTABLEP using (SETQ TTBL (\GTTERMTABLE TTBL T))
                             TERMSA _ (create CHARTABLE using (fetch TERMSA of TTBL])

(DELETECONTROL
  [LAMBDA (TYPE MESSAGE TTBL)                                (* lmm " 1-Jan-85 21:34")
    (PROG [VAL (TBL (\GTTERMTABLE TTBL (NULL MESSAGE]
          (SETQ VAL (SELECTQ TYPE
                        ((ECHO NOECHO) 
                             (PROG1 (fetch DELCHARECHO of TBL)
                                    (replace DELCHARECHO of TBL with TYPE)))
                        (DELCHARECHO (PROG1 (fetch DELCHARECHO of TBL)
                                            (SELECTQ MESSAGE
                                                (NIL         (* ; "Called only to get current value"))
                                                ((ECHO NOECHO) 
                                                     (replace DELCHARECHO of TBL with MESSAGE))
                                                (LISPERROR "ILLEGAL ARG" MESSAGE))))
                        ((LINEDELETE DELETELINE) 
                             [PROG1 (fetch LINEDELETE of TBL)
                                    (AND MESSAGE (replace LINEDELETE of TBL with (\LITCHECK MESSAGE])
                        (1STCHDEL [PROG1 (fetch 1STCHDEL of TBL)
                                         (AND MESSAGE (replace 1STCHDEL of TBL with (\LITCHECK 
                                                                                           MESSAGE])
                        (NTHCHDEL [PROG1 (fetch NTHCHDEL of TBL)
                                         (AND MESSAGE (replace NTHCHDEL of TBL with (\LITCHECK 
                                                                                           MESSAGE])
                        (POSTCHDEL [PROG1 (fetch POSTCHDEL of TBL)
                                          (AND MESSAGE (replace POSTCHDEL of TBL with (\LITCHECK
                                                                                       MESSAGE])
                        (EMPTYCHDEL [PROG1 (fetch EMPTYCHDEL of TBL)
                                           (AND MESSAGE (replace EMPTYCHDEL of TBL
                                                           with (\LITCHECK MESSAGE])
                        (LISPERROR "ILLEGAL ARG" TYPE)))
          (RETURN (COND
                     ((STRINGP VAL)
                      (CONCAT VAL))
                     (T VAL])

(GETDELETECONTROL
  [LAMBDA (TYPE TTBL)                                        (* lmm " 1-Jan-85 21:20")
    (PROG (TBL VAL)
          (SETQ TBL (\GTTERMTABLE TTBL T))
          (SETQ VAL (SELECTQ TYPE
                        ((ECHO NOECHO) 
                             (fetch DELCHARECHO of TBL))
                        (DELCHARECHO (fetch DELCHARECHO of TBL))
                        ((LINEDELETE DELETELINE) 
                             (fetch LINEDELETE of TBL))
                        (1STCHDEL (fetch 1STCHDEL of TBL))
                        (NTHCHDEL (fetch NTHCHDEL of TBL))
                        (POSTCHDEL (fetch POSTCHDEL of TBL))
                        (EMPTYCHDEL (fetch EMPTYCHDEL of TBL))
                        (LISPERROR "ILLEGAL ARG" TYPE)))
          (RETURN (COND
                     ((STRINGP VAL)
                      (CONCAT VAL))
                     (T VAL])

(ECHOCHAR
  [LAMBDA (CHARCODE MODE TTBL)                               (* lmm " 1-Jan-85 21:29")
    (COND
       ((LISTP CHARCODE)
        (for X in CHARCODE do (ECHOCHAR X MODE TTBL)))
       (T (PROG [B (SA (fetch TERMSA of (\GTTERMTABLE TTBL (NULL MODE]
                (RETURN (PROG1 (SELECTC (fetch CCECHO of (SETQ B (\SYNCODE SA CHARCODE)))
                                   (REAL.CCE 'REAL)
                                   (IGNORE.CCE 'IGNORE)
                                   (SIMULATE.CCE 'SIMULATE)
                                   'INDICATE)
                               (AND MODE (\SETSYNCODE SA CHARCODE (create TERMCODE
                                                                     using B CCECHO _
                                                                           (SELECTQ MODE
                                                                               (REAL REAL.CCE)
                                                                               (IGNORE IGNORE.CCE)
                                                                               (SIMULATE SIMULATE.CCE)
                                                                               ((INDICATE UPARROW) 
                                                                                    INDICATE.CCE)
                                                                               (\ILLEGAL.ARG MODE])

(ECHOCONTROL
  [LAMBDA (CHAR MODE TTBL)                                   (* rmk%: "20-Nov-84 15:14")
    (PROG ((C (\GETCHARCODE CHAR)))
          (OR [AND (\THINCHARCODEP C)
                   (OR (ILESSP C 40Q)
                       (AND (IGEQ C (CHARCODE A))
                            (ILEQ C (CHARCODE Z))
                            (SETQ C (IDIFFERENCE C 100Q]
              (\ILLEGAL.ARG C))
          (RETURN (ECHOCHAR C MODE TTBL])

(ECHOMODE
  [LAMBDA (FLG TTBL)                                         (* rmk%: " 8-FEB-80 11:57")
    (PROG1 (fetch ECHOFLG of (SETQ TTBL (\GTTERMTABLE TTBL)))
           (replace ECHOFLG of TTBL with (AND FLG T])

(GETECHOMODE
  [LAMBDA (TTBL)                                             (* lmm " 1-Jan-85 21:21")
    (fetch ECHOFLG of (\GTTERMTABLE TTBL T])

(GETCONTROL
  [LAMBDA (TTBL)                                             (* lmm " 1-Jan-85 21:21")
    (fetch CONTROLFLG of (\GTTERMTABLE TTBL T])

(GETTERMTABLE
  [LAMBDA (TTBL)
    (\GTTERMTABLE TTBL NIL])

(RAISE
  [LAMBDA (FLG TTBL)                                         (* bvm%: "14-Feb-85 00:17")
    (PROG1 (fetch RAISEFLG of (SETQ TTBL (\GTTERMTABLE TTBL)))
           (replace RAISEFLG of TTBL with (COND
                                             ((EQ FLG 0)
                                              0)
                                             (FLG T])

(GETRAISE
  [LAMBDA (TTBL)                                             (* lmm " 1-Jan-85 21:21")
    (fetch RAISEFLG of (\GTTERMTABLE TTBL T])

(RESETTERMTABLE
  [LAMBDA (TTBL FROM)                                        (* lmm "14-APR-81 14:34")
    (PROG ((FR (\GTTERMTABLE FROM T))
           (TT (\GTTERMTABLE TTBL)))
          (\COPYSYNTAX (fetch TERMSA of FR)
                 (fetch TERMSA of TT))
          (replace RAISEFLG of TT with (fetch RAISEFLG of FR))
          (replace DELCHARECHO of TT with (fetch DELCHARECHO of FR))
          (replace LINEDELETE of TT with (fetch LINEDELETE of FR))
          (replace 1STCHDEL of TT with (fetch 1STCHDEL of FR))
          (replace NTHCHDEL of TT with (fetch NTHCHDEL of FR))
          (replace POSTCHDEL of TT with (fetch POSTCHDEL of FR))
          (replace EMPTYCHDEL of TT with (fetch EMPTYCHDEL of FR))
          (replace CONTROLFLG of TT with (fetch CONTROLFLG of FR))
          (replace ECHOFLG of TT with (fetch ECHOFLG of FR))
          (RETURN TT])

(SETTERMTABLE
  [LAMBDA (TBL)                                              (* rmk%: " 8-FEB-80 12:16")
    (PROG1 \PRIMTERMTABLE (SETQ \PRIMTERMSA (fetch TERMSA of (SETQ \PRIMTERMTABLE (\GTTERMTABLE
                                                                                   TBL])

(TERMTABLEP
  [LAMBDA (TTBL)                                             (* rmk%: "20-FEB-80 12:29")
    (AND (type? TERMTABLEP TTBL)
         TTBL])

(\GETTERMSYNTAX
  [LAMBDA (C TBL)                                            (* rmk%: "24-APR-80 09:44")
    (\TERMCODETOCLASS (fetch TERMCLASS of (\SYNCODE (fetch TERMSA of TBL)
                                                 C])

(\GTTERMTABLE
  [LAMBDA (TTBL FLG)                                         (* lmm " 6-MAY-80 20:35")
    (COND
       ((type? TERMTABLEP TTBL)
        TTBL)
       ((NULL TTBL)
        \PRIMTERMTABLE)
       ((AND (EQ TTBL 'ORIG)
             FLG)
        \ORIGTERMTABLE)
       (T (LISPERROR "ILLEGAL TERMINAL TABLE" TTBL])

(\ORIGTERMTABLE
  [LAMBDA NIL                                                (* rrb " 5-Oct-85 10:33")
          
          (* ;; "Creates the original terminal table")
          
          (* ;; "must be created with a hash table big enough to hold all of the indicates in character set 1 because this gets evaluated in the loadup before HASHOVERFLOW is defined.  rrb 5-oct-85")

    (PROG ((TBL (create TERMTABLEP
                       TERMSA _ (create CHARTABLE
                                       NSCHARHASH _ (\CREATENSCHARHASH 454Q))
                       DELCHARECHO _ 'ECHO
                       ECHOFLG _ T
                       LINEDELETE _ "##
"
                       1STCHDEL _ "\"
                       NTHCHDEL _ ""
                       POSTCHDEL _ "\"
                       EMPTYCHDEL _ "##
")))
          (PROGN (\SETTERMSYNTAX (SELECTQ (SYSTEMTYPE)
                                     ((TENEX D) 
                                          (CHARCODE ^A))
                                     ((JERICHO VAX TOPS-20) 
                                          (CHARCODE DEL))
                                     (SHOULDNT))
                        'CHARDELETE TBL)
                 (\SETTERMSYNTAX (CHARCODE ^H)
                        'CHARDELETE TBL)                     (* ; 
                                                         "Added ^H as a CHARDELETE character 9/30/85")
                 (\SETTERMSYNTAX (CHARCODE ^W)
                        'WORDDELETE TBL)
                 (\SETTERMSYNTAX (SELECTQ (SYSTEMTYPE)
                                     ((TENEX D) 
                                          (CHARCODE ^Q))
                                     ((JERICHO VAX) 
                                          (CHARCODE ^U))
                                     (SHOULDNT))
                        'LINEDELETE TBL)
                 (\SETTERMSYNTAX (CHARCODE ^R)
                        'RETYPE TBL)
                 (\SETTERMSYNTAX (CHARCODE ^V)
                        'CTRLV TBL)
                 (\SETTERMSYNTAX (CHARCODE EOL)
                        'WAKEUPCHAR TBL)
                 (for C
                    in (CHARCODE (SPACE TAB ! @ %# $ ~ & * - = + %| { } ^ _ %: ; < > %, %. ? /))
                    do (\SETTERMSYNTAX C 'WORDSEPR TBL)))
          (PROGN (ECHOCHAR (CHARCODE (NULL ^A ^B ^C ^D ^E ^F ^H ^K ^L ^N ^O ^P ^Q ^R ^S ^T ^U ^V ^W 
                                           ^X ^Y ^Z ^\ ^%] ^^))
                        'INDICATE TBL)
                 (ECHOCHAR (CHARCODE (BELL TAB LF CR))
                        'REAL TBL)
                 (SELECTQ (SYSTEMTYPE)
                     (D (ECHOCHAR (CHARCODE (NULL ^A ^W ^Q ^R))
                               'IGNORE TBL)
                        (ECHOCHAR (CHARCODE (BELL TAB ESCAPE LF TENEXEOL))
                               'SIMULATE TBL))
                     (JERICHO (ECHOCHAR [CONSTANT (CONS ERASECHARCODE (CHARCODE (BELL TAB ESCAPE EOL]
                                     'SIMULATE TBL))
                     (VAX (ECHOCHAR (CHARCODE (TAB ESCAPE EOL DEL))
                                 'SIMULATE TBL))
                     NIL))
          (for C from 200Q to \MAXTHINCHAR do (ECHOCHAR C 'REAL TBL))
          (for C from (CHARCODE 1,0) to (CHARCODE 1,377) do (ECHOCHAR C 'INDICATE TBL))
          (RETURN TBL])

(\SETTERMSYNTAX
  [LAMBDA (C CLASS TBL)                                      (* rmk%: "26-Mar-85 23:45")
          
          (* ;; "Changes the terminal syntax class for charcode C.  Unlike Interlisp-10, does not turn off previous characters for CHARDELETE, etc.  classes")

    (\SETSYNCODE (fetch TERMSA of TBL)
           C
           (create TERMCODE using (\SYNCODE (fetch TERMSA of TBL)
                                         C)
                                  TERMCLASS _ (OR (\TERMCLASSTOCODE CLASS)
                                                  (LISPERROR "ILLEGAL ARG" CLASS])

(\TERMCLASSTOCODE
  [LAMBDA (CLASS)                                            (* rmk%: "11-FEB-82 21:24")
    (SELECTQ CLASS
        ((EOL WAKEUPCHAR) 
             EOL.TC)
        (NONE NONE.TC)
        (CHARDELETE CHARDELETE.TC)
        (WORDDELETE WORDDELETE.TC)
        (WORDSEPR WORDSEPR.TC)
        (LINEDELETE LINEDELETE.TC)
        (RETYPE RETYPE.TC)
        ((CTRLV CNTRLV) 
             CTRLV.TC)
        NIL])

(\TERMCODETOCLASS
  [LAMBDA (CODE)                                             (* rmk%: "11-FEB-82 21:24")
    (SELECTC CODE
        (EOL.TC 'EOL)
        (NONE.TC 'NONE)
        (CHARDELETE.TC 'CHARDELETE)
        (WORDDELETE.TC 'WORDDELETE)
        (WORDSEPR.TC 'WORDSEPR)
        (LINEDELETE.TC 'LINEDELETE)
        (RETYPE.TC 'RETYPE)
        (CTRLV.TC 'CNTRLV)
        NIL])

(\LITCHECK
  [LAMBDA (X)                                                (* rmk%: "11-FEB-82 21:26")
    (COND
       ((EQ X 'BACKUP)                                       (* ; 
                                         "Means take terminal/implementation dependent backup action")
        X)
       ((LITATOM X)
        (MKSTRING X))
       ((STRINGP X)
        (CONCAT X))
       (T (\ILLEGAL.ARG X])
)
(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ CCECHOMODES (REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE))
(DECLARE%: EVAL@COMPILE 

(RPAQQ REAL.CCE 0)

(RPAQQ IGNORE.CCE 10Q)

(RPAQQ SIMULATE.CCE 20Q)

(RPAQQ INDICATE.CCE 30Q)


(CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)
)

(RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC 
                              RETYPE.TC CTRLV.TC))
(DECLARE%: EVAL@COMPILE 

(RPAQQ NONE.TC 0)

(RPAQQ EOL.TC 1)

(RPAQQ CHARDELETE.TC 2)

(RPAQQ WORDDELETE.TC 6)

(RPAQQ WORDSEPR.TC 7)

(RPAQQ LINEDELETE.TC 3)

(RPAQQ RETYPE.TC 4)

(RPAQQ CTRLV.TC 5)


(CONSTANTS NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC)
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 30Q))
                         (TERMCLASS (LOGAND DATUM 7)))       (* ; 
                                                  "We assume that values are appropriately shifted")
                        (CREATE (LOGOR CCECHO TERMCLASS)))

(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL 
                                EMPTYCHDEL (CONTROLFLG FLAG)
                                (ECHOFLG FLAG))
                         TERMSA _ (create CHARTABLE))
)

(/DECLAREDATATYPE 'TERMTABLEP '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG
                                      FLAG)
       '((TERMTABLEP 0 POINTER)
         (TERMTABLEP 2 POINTER)
         (TERMTABLEP 4 POINTER)
         (TERMTABLEP 6 POINTER)
         (TERMTABLEP 10Q POINTER)
         (TERMTABLEP 12Q POINTER)
         (TERMTABLEP 14Q POINTER)
         (TERMTABLEP 16Q POINTER)
         (TERMTABLEP 16Q (FLAGBITS . 0))
         (TERMTABLEP 16Q (FLAGBITS . 20Q)))
       '20Q)

(* "END EXPORTED DEFINITIONS")

)

(/DECLAREDATATYPE 'TERMTABLEP '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG
                                      FLAG)
       '((TERMTABLEP 0 POINTER)
         (TERMTABLEP 2 POINTER)
         (TERMTABLEP 4 POINTER)
         (TERMTABLEP 6 POINTER)
         (TERMTABLEP 10Q POINTER)
         (TERMTABLEP 12Q POINTER)
         (TERMTABLEP 14Q POINTER)
         (TERMTABLEP 16Q POINTER)
         (TERMTABLEP 16Q (FLAGBITS . 0))
         (TERMTABLEP 16Q (FLAGBITS . 20Q)))
       '20Q)



(* ; "read tables")

(DEFINEQ

(COPYREADTABLE
  [LAMBDA (RDTBL)                                            (* rmk%: " 2-FEB-80 12:26")
    (RESETREADTABLE (create READTABLEP)
           (\GTREADTABLE RDTBL T])

(FIND-READTABLE
  [LAMBDA (NAME)                                             (* bvm%: "27-Jul-86 15:53")
    (GETHASH NAME \READTABLEHASH])

(IN-READTABLE
  [LAMBDA (RDTBL)                                            (* bvm%: "27-Jul-86 15:55")
    (SETQ *READTABLE* (\GTREADTABLE RDTBL T])

(ESCAPE
  [LAMBDA (FLG RDTBL)                                        (* rmk%: " 1-FEB-80 13:12")
    (PROG1 (fetch ESCAPEFLG of (SETQ RDTBL (\GTREADTABLE RDTBL)))
           (replace ESCAPEFLG of RDTBL with (NEQ FLG NIL])

(GETBRK
  [LAMBDA (RDTBL)                                            (* rmk%: " 2-MAY-80 17:04")
    (GETSYNTAX 'BREAK RDTBL])

(GETREADTABLE
  [LAMBDA (RDTBL)                                            (* lmm%: 4-FEB-76 3 62Q)
    (\GTREADTABLE RDTBL])

(GETSEPR
  [LAMBDA (RDTBL)                                            (* rmk%: " 2-MAY-80 17:05")
    (GETSYNTAX 'SEPR RDTBL])

(READMACROS
  [LAMBDA (FLG RDTBL)                                        (* rmk%: " 1-FEB-80 13:11")
    (PROG1 (fetch READMACROFLG of (SETQ RDTBL (\GTREADTABLE RDTBL)))
           (replace READMACROFLG of RDTBL with (NEQ FLG NIL])

(READTABLEP
  [LAMBDA (RDTBL)                                            (* rmk%: "20-FEB-80 12:32")
    (AND (type? READTABLEP RDTBL)
         RDTBL])

(READTABLEPROP
  [LAMBDA ARGS                                               (* bvm%: "28-Aug-86 15:28")
    (COND
       ((LESSP ARGS 2)
        (\ILLEGAL.ARG NIL))
       ((GREATERP ARGS 3)
        (\ILLEGAL.ARG (ARG ARGS 4)))
       (T (LET [(RDTBL (\GTREADTABLE (ARG ARGS 1)))
                (NEWVALUEP (EQ ARGS 3))
                (NEWVALUE (AND (EQ ARGS 3)
                               (ARG ARGS 3]
               (SELECTQ (ARG ARGS 2)
                   (NUMBERBASE [PROG1 (fetch (READTABLEP NUMBERBASE) of RDTBL)
                                      (COND
                                         (NEWVALUEP (replace (READTABLEP NUMBERBASE) of RDTBL
                                                       with NEWVALUE])
                   (NAME [LET ((OLDNAME (fetch (READTABLEP READTBLNAME) of RDTBL)))
                              (PROG1 OLDNAME (COND
                                                (NEWVALUEP (COND
                                                              (OLDNAME (REMHASH OLDNAME 
                                                                              \READTABLEHASH)))
                                                       (replace (READTABLEP READTBLNAME) of RDTBL
                                                          with NEWVALUE)
                                                       (PUTHASH NEWVALUE RDTBL \READTABLEHASH])
                   (COMMONLISP [PROG1 (fetch (READTABLEP COMMONLISP) of RDTBL)
                                      (COND
                                         (NEWVALUEP (replace (READTABLEP COMMONLISP) of RDTBL
                                                       with NEWVALUE)
                                                (if NEWVALUE
                                                    then     (* ; 
                                           "COMMONLISP implies COMMONNUMSYNTAX and not USESILPACKAGE")
                                                         (replace (READTABLEP COMMONNUMSYNTAX)
                                                            of RDTBL with T)
                                                         (replace (READTABLEP USESILPACKAGE)
                                                            of RDTBL with NIL])
                   (COMMONNUMSYNTAX 
                        [PROG1 (fetch (READTABLEP COMMONNUMSYNTAX) of RDTBL)
                               (COND
                                  (NEWVALUEP (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL
                                                with NEWVALUE])
                   (USESILPACKAGE [PROG1 (fetch (READTABLEP USESILPACKAGE) of RDTBL)
                                         (COND
                                            (NEWVALUEP (replace (READTABLEP USESILPACKAGE)
                                                          of RDTBL with NEWVALUE])
                   (CASEINSENSITIVE 
                        [PROG1 (fetch (READTABLEP CASEINSENSITIVE) of RDTBL)
                               (COND
                                  (NEWVALUEP (replace (READTABLEP CASEINSENSITIVE) of RDTBL
                                                with NEWVALUE])
                   (ESCAPECHAR [PROG1 (fetch (READTABLEP ESCAPECHAR) of RDTBL)
                                      (COND
                                         (NEWVALUEP (\SETREADSYNTAX NEWVALUE 'ESCAPE RDTBL)
                                                (replace (READTABLEP ESCAPECHAR) of RDTBL
                                                   with NEWVALUE])
                   (MULTIPLE-ESCAPECHAR 
                        [PROG1 (fetch (READTABLEP MULTESCAPECHAR) of RDTBL)
                               (COND
                                  (NEWVALUEP (\SETREADSYNTAX NEWVALUE 'MULTIPLE-ESCAPE RDTBL)
                                         (replace (READTABLEP MULTESCAPECHAR) of RDTBL with NEWVALUE])
                   (PACKAGECHAR [PROG1 (fetch (READTABLEP PACKAGECHAR) of RDTBL)
                                       (COND
                                          (NEWVALUEP (\SETREADSYNTAX NEWVALUE 'PACKAGEDELIM RDTBL)
                                                 (replace (READTABLEP PACKAGECHAR) of RDTBL
                                                    with NEWVALUE])
                   (HASHMACROCHAR [PROG1 (fetch (READTABLEP HASHMACROCHAR) of RDTBL)
                                         (COND
                                            (NEWVALUEP (\SETREADSYNTAX NEWVALUE
                                                              '(INFIX ALWAYS NONIMMEDIATE ESCQUOTE 
                                                                      READVBAR) RDTBL)
                                                   (replace (READTABLEP HASHMACROCHAR) of RDTBL
                                                      with NEWVALUE])
                   (\ILLEGAL.ARG (ARG ARGS 2])

(RESETREADTABLE
  [LAMBDA (RDTBL FROM)                                  (* ; "Edited 20-Apr-2018 16:22 by rmk:")
                                                             (* bvm%: "27-Aug-86 22:28")

    (* ;; "RMK: Copy the macrodefs")

    [replace READMACROFLG of (SETQ RDTBL (\GTREADTABLE RDTBL))
       with (fetch READMACROFLG of (SETQ FROM (\GTREADTABLE FROM T]
    (replace ESCAPEFLG of RDTBL with (fetch ESCAPEFLG of FROM))
    (replace (READTABLEP COMMONLISP) of RDTBL with (fetch (READTABLEP 
                                                                                     COMMONLISP)
                                                                      of FROM))
    (replace (READTABLEP NUMBERBASE) of RDTBL with (fetch (READTABLEP 
                                                                                     NUMBERBASE)
                                                                      of FROM))
    (replace (READTABLEP CASEINSENSITIVE) of RDTBL with (fetch (READTABLEP
                                                                                    CASEINSENSITIVE)
                                                                           of FROM))
    (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL with (fetch (READTABLEP
                                                                                    COMMONNUMSYNTAX)
                                                                           of FROM))
    (replace (READTABLEP USESILPACKAGE) of RDTBL with (fetch (READTABLEP
                                                                                  USESILPACKAGE)
                                                                         of FROM))
    (replace (READTABLEP HASHMACROCHAR) of RDTBL with (fetch (READTABLEP
                                                                                  HASHMACROCHAR)
                                                                         of FROM))
    (replace (READTABLEP ESCAPECHAR) of RDTBL with (fetch (READTABLEP 
                                                                                     ESCAPECHAR)
                                                                      of FROM))
    (replace (READTABLEP MULTESCAPECHAR) of RDTBL with (fetch (READTABLEP
                                                                                   MULTESCAPECHAR)
                                                                          of FROM))
    (replace (READTABLEP PACKAGECHAR) of RDTBL with (fetch (READTABLEP 
                                                                                      PACKAGECHAR)
                                                                       of FROM))
    (replace (READTABLEP DISPATCHMACRODEFS) of RDTBL with (COPY (fetch
                                                                                 (READTABLEP
                                                                                  DISPATCHMACRODEFS)
                                                                                   of FROM)))

    (* ;; "Placeholder.  If DISPATCHMACRODEFS ends up containing a CHARTABLE or a hash table, will have to do a REHASH or \COPYSYNTAX as well")

    [LET ((RDEFS (fetch (READTABLEP READMACRODEFS) of RDTBL))
          (FDEFS (fetch (READTABLEP READMACRODEFS) of FROM)))
         [COND
            (RDEFS (CLRHASH RDEFS))
            (T (SETQ RDEFS (replace (READTABLEP READMACRODEFS) of RDTBL
                              with (HASHARRAY (HARRAYSIZE FDEFS)
                                              7]
         (AND FDEFS (MAPHASH FDEFS (FUNCTION (LAMBDA (VAL KEY)
                                               (PUTHASH KEY (COPY VAL)
                                                      RDEFS]
    (\COPYSYNTAX (fetch READSA of FROM)
           (fetch READSA of RDTBL))
    RDTBL])

(SETBRK
  [LAMBDA (LST FLG RDTBL)                                    (* rmk%: "13-AUG-81 00:01")
                                                             (* ; 
             "This is a very ugly def which needs to be cleaned up cause a lot of people call SETBRK")
    (COND
       [(EQ LST T)
        [MAPC (GETSYNTAX 'BREAK RDTBL)
              (FUNCTION (LAMBDA (X)
                          (SETSYNTAX X 'OTHER RDTBL]
        (MAPC (GETSYNTAX 'BREAK (COND
                                   ((EQ RDTBL T)
                                    'ORIG)
                                   (T T)))
              (FUNCTION (LAMBDA (X)
                          (SETSYNTAX X 'BREAK RDTBL]
       (T (SELECTQ FLG
              (NIL                                           (* ; "reset")
                   [MAPC (GETSYNTAX 'BREAK RDTBL)
                         (FUNCTION (LAMBDA (X)
                                     (OR (MEMB X LST)
                                         (SETSYNTAX X 'OTHER RDTBL]
                   [MAPC LST (FUNCTION (LAMBDA (X)
                                         (SETSYNTAX X 'BREAK RDTBL])
              (0                                             (* ; "clear out lst")
                 [MAPC LST (FUNCTION (LAMBDA (X)
                                       (SETSYNTAX X 'OTHER RDTBL])
              (1                                             (* ; "add chars")
                 [MAPC LST (FUNCTION (LAMBDA (X)
                                       (SETSYNTAX X 'BREAK RDTBL])
              NIL])

(SETREADTABLE
  [LAMBDA (RDTBL FLG)                                        (* bvm%: " 4-May-86 16:32")
    (PROG1 *READTABLE* (SETQ *READTABLE* (\GTREADTABLE RDTBL])

(SETSEPR
  [LAMBDA (LST FLG RDTBL)                                    (* rmk%: " 8-JUN-80 07:16")
                                                             (* ; 
                                                             "This one also needs to be cleaned up")
    (COND
       [(EQ LST T)
        [MAPC (GETSYNTAX 'SEPR RDTBL)
              (FUNCTION (LAMBDA (X)
                          (SETSYNTAX X 'OTHER RDTBL]
        (MAPC (GETSYNTAX 'SEPR (COND
                                  ((EQ RDTBL T)
                                   'ORIG)
                                  (T T)))
              (FUNCTION (LAMBDA (X)
                          (SETSYNTAX X 'SEPR RDTBL]
       (T (SELECTQ FLG
              (NIL                                           (* ; "reset")
                   [MAPC (GETSYNTAX 'SEPR RDTBL)
                         (FUNCTION (LAMBDA (X)
                                     (SETSYNTAX X 'OTHER RDTBL]
                   [MAPC LST (FUNCTION (LAMBDA (X)
                                         (SETSYNTAX X 'SEPR RDTBL])
              (0                                             (* ; "clear out lst")
                 [MAPC LST (FUNCTION (LAMBDA (X)
                                       (SETSYNTAX X 'OTHER RDTBL])
              (1                                             (* ; "add chars")
                 [MAPC LST (FUNCTION (LAMBDA (X)
                                       (SETSYNTAX X 'SEPR RDTBL])
              NIL])

(\GETREADSYNTAX
  [LAMBDA (C TBL)                                            (* bvm%: "30-Jun-86 17:49")
    (LET ((B (\SYNCODE (fetch READSA of TBL)
                    C)))
          
          (* ;; "This will turn into a SELECTQ that keys off syntax code numbers and produces class tokens.  The default clause at the end: if it's not a built-in class, must be a macro")
          
          (* ;; "Sample code:")
                                                             (* (SELECTQ B (0 (QUOTE OTHER))
                                                             (140Q (QUOTE SEPRCHAR))
                                                             (160Q (QUOTE BREAKCHAR))
                                                             (161Q (QUOTE STRINGDELIM))
                                                             (162Q (QUOTE LEFTPAREN))
                                                             (163Q (QUOTE RIGHTPAREN))
                                                             (164Q (QUOTE LEFTBRACKET))
                                                             (165Q (QUOTE RIGHTBRACKET))
                                                             (106Q (QUOTE ESCAPE))
                                                             (107Q (QUOTE MULTIPLE-ESCAPE))
                                                             (105Q (QUOTE PACKAGEDELIM)) <default>))
         (\COMPUTED.FORM `(SELECTQ B
                              (\,@ [for PAIR in READCLASSTOKENS
                                      collect (LIST (EVAL (CADR PAIR))
                                                    (KWOTE (CAR PAIR])
                              (LET ((E (\GETREADMACRODEF C TBL))
                                    KEY)
                                   `(,(fetch MACROTYPE of E)
                                     ,(fetch (CONTEXTS KEY) of (fetch MACROCONTEXT of B))
                                     ,@(AND (NEQ (SETQ KEY (fetch (WAKEUPS KEY)
                                                              of (fetch WAKEUP of B)))
                                                 'NONIMMEDIATE)
                                            (LIST KEY))
                                     ,@(AND (NEQ (SETQ KEY (fetch (ESCAPES KEY)
                                                              of (fetch ESCAPE of B)))
                                                 'ESCQUOTE)
                                            (LIST KEY))
                                     ,(fetch MACROFN of E])

(\GTREADTABLE
  [LAMBDA (X FLG)                                            (* bvm%: " 5-May-86 11:05")
    (SELECTQ X
        ((NIL T) 
             (\DTEST *READTABLE* 'READTABLEP))
        (\GTREADTABLE1 X FLG])

(\GTREADTABLE1
  [LAMBDA (X FLG)                                            (* bvm%: "27-Jul-86 15:37")
    (COND
       ((type? READTABLEP X)
        X)
       ((AND FLG (GETHASH X \READTABLEHASH)))
       (T (LISPERROR "ILLEGAL READTABLE" X])

(\ORIGREADTABLE
  [LAMBDA NIL                                                (* ; "Edited 16-Apr-87 17:45 by bvm:")
          
          (* ;; "Creates a copy of the 'original' read-table.")

    (PROG [(TBL (create READTABLEP
                       READMACROFLG _ T
                       ESCAPEFLG _ T
                       NUMBERBASE _ 12Q
                       USESILPACKAGE _ T
                       ESCAPECHAR _ (CHARCODE %%)
                       PACKAGECHAR _ (PROGN 
          
          (* ;; "Need to have a character for package delimiter in all read tables, but for old read tables want one that is unlikely to have appeared in a symbol in an old source file.  Also would like it to be a 7-bit char, so we don't needlessly force MAKEFILE to produce binary files.")

                                            (CHARCODE "^^"))
                       HASHMACROCHAR _ (CHARCODE "|"]
          
          (* ;; "Actually, '|' is not defined in ORIG table, but rather later.  But the radix printer and others want it, and this is better than nothing")

          (SETSEPR (CHARCODE (SPACE TENEXEOL CR ^L LF TAB))
                 1 TBL)
          (\SETREADSYNTAX (CHARCODE %])
                 'RIGHTBRACKET TBL)
          (\SETREADSYNTAX (CHARCODE %[)
                 'LEFTBRACKET TBL)
          (\SETREADSYNTAX (CHARCODE %))
                 'RIGHTPAREN TBL)
          (\SETREADSYNTAX (CHARCODE %()
                 'LEFTPAREN TBL)
          (\SETREADSYNTAX (CHARCODE %%)
                 'ESCAPE TBL)
          (\SETREADSYNTAX (CHARCODE %")
                 'STRINGDELIM TBL)
          (\SETREADSYNTAX 247Q 'PACKAGEDELIM TBL)            (* ; "Old choice for package delim char: the NS section symbol.  Keep for compatibility with Lyric Beta files")
          (\SETREADSYNTAX (CHARCODE "^^")
                 'PACKAGEDELIM TBL)
          (RETURN TBL])

(\READCLASSTOCODE
  [LAMBDA (CLASS)                                            (* bvm%: " 9-Jul-85 00:43")

(* ;;; "This turns into a SELECTQ that goes from CLASS token to numeric code")

    (\COMPUTED.FORM `(SELECTQ CLASS
                         (\,@ READCLASSTOKENS)
                         (SEPR                               (* ; "Synonym for SEPRCHAR")
                               SEPRCHAR.RC)
                         NIL])

(\SETMACROSYNTAX
  [LAMBDA (C CLASS TBL)                                      (* rmk%: " 3-Jan-84 13:20")
    (OR (AND (FMEMB (CAR CLASS)
                    '(MACRO SPLICE INFIX))
             (CDR CLASS))
        (\ILLEGAL.ARG CLASS))
    (PROG (CONTEXT WAKEUP ESCAPE (LST CLASS)
                 (A (fetch READMACRODEFS of TBL)))
      LP  (COND
             ([CDR (SETQ LST (LISTP (CDR LST]
              (OR [AND (NULL CONTEXT)
                       (SETQ CONTEXT (fetch (CONTEXTS VAL) of (CAR LST]
                  [AND (NULL WAKEUP)
                       (SETQ WAKEUP (fetch (WAKEUPS VAL) of (CAR LST]
                  [AND (NULL ESCAPE)
                       (SETQ ESCAPE (fetch (ESCAPES VAL) of (CAR LST]
                  (\ILLEGAL.ARG CLASS))
              (GO LP)))
          (OR (LISTP LST)
              (\ILLEGAL.ARG CLASS))
          [COND
             (A 
          
          (* ;; "This hack guarantees that the hasharray will not overflow and cause an error in the uninterruptable PUTHASH below.  If it didn't already have a value for C, then the macro bits are not set in C's syntax code, so the T value is harmless.")

                (OR (GETHASH C A)
                    (PUTHASH C T A)))
             (T (replace READMACRODEFS of TBL with (SETQ A (HASHARRAY 7 7]
          (UNINTERRUPTABLY
              (PUTHASH C (create READMACRODEF
                                MACROTYPE _ (CAR CLASS)
                                MACROFN _ (CAR LST))
                     A)
              (\SETSYNCODE (fetch READSA of TBL)
                     C
                     (LOGOR (OR CONTEXT ALWAYS.RMC)
                            (OR ESCAPE ESC.RME)
                            (OR WAKEUP NONIMMEDIATE.RMW))))])

(\SETREADSYNTAX
  [LAMBDA (C CLASS TBL)                                      (* bvm%: " 8-Mar-86 16:37")
    (PROG ((OLDSYNTAX (\SYNCODE (fetch (READTABLEP READSA) of TBL)
                             C))
           TEM)
          [COND
             ((EQ CLASS 'BREAK)
              (COND
                 ((fetch BREAK of OLDSYNTAX)
                  (RETURN))
                 (T (SETQ CLASS 'BREAKCHAR]                  (* ; 
                    "If already a BREAK character but also something else, like LPAR, leave it alone")
          (COND
             ((LISTP CLASS)
              (\SETMACROSYNTAX C CLASS TBL))
             ((SETQ TEM (\READCLASSTOCODE CLASS))
              (UNINTERRUPTABLY
                  [COND
                     ((fetch MACROP of OLDSYNTAX)            (* ; "No longer a macro")
                      (REMHASH C (fetch READMACRODEFS of TBL]
                  (\SETSYNCODE (fetch READSA of TBL)
                         C TEM)))
             (T (\ILLEGAL.ARG CLASS])

(\READTABLEP.DEFPRINT
  [LAMBDA (RDTBL STREAM)                                     (* bvm%: "13-Oct-86 17:32")
          
          (* ;; "Print read table as, for example, #<ReadTable name/76,5432>")

    (LET ((NAME (fetch (READTABLEP READTBLNAME) of RDTBL)))
         [.SPACECHECK. STREAM (IPLUS (CONSTANT (NCHARS "<ReadTable />"))
                                     (PROGN                  (* ; "Longest address is `177,177777'")
                                            12Q)
                                     (COND
                                        (NAME (NCHARS NAME))
                                        (T 0]
         (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
         (\SOUT "<ReadTable" STREAM)
         (COND
            (NAME (\OUTCHAR STREAM (CHARCODE SPACE))
                  (\SOUT (MKSTRING NAME)
                         STREAM)))
         (\OUTCHAR STREAM (CHARCODE /))
         (\PRINTADDR RDTBL STREAM)
         (\OUTCHAR STREAM (CHARCODE >))
         T])
)

(PUTPROPS READTABLEPROP ARGNAMES (RDTBL PROP NEWVALUE))
(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ READCLASSTOKENS
       ((OTHER 0)
        (SEPRCHAR (LOGOR ESCAPEBIT STOPATOMBIT 0))
        (BREAKCHAR (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))
        (STRINGDELIM (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))
        (LEFTPAREN (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))
        (RIGHTPAREN (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))
        (LEFTBRACKET (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))
        (RIGHTBRACKET (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))
        (ESCAPE (LOGOR ESCAPEBIT INNERESCAPEBIT 6))
        (MULTIPLE-ESCAPE (LOGOR ESCAPEBIT INNERESCAPEBIT 7))
        (PACKAGEDELIM (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))

(RPAQ READCLASSES [MAPCAR READCLASSTOKENS (FUNCTION (LAMBDA (PAIR)
                                                               (LIST (PACK* (CAR PAIR)
                                                                            ".RC")
                                                                     (CADR PAIR])

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \COMPUTED.FORM  MACRO
   [X (CONS 'PROGN (MAPCAR X (FUNCTION EVAL])
)

(DECLARE%: EVAL@COMPILE

(ACCESSFNS CONTEXTS ((KEY (SELECTC DATUM
                                  (ALWAYS.RMC 'ALWAYS)
                                  (FIRST.RMC 'FIRST)
                                  (ALONE.RMC 'ALONE)
                                  NIL))
                         (VAL (SELECTQ DATUM
                                  (ALWAYS ALWAYS.RMC)
                                  (FIRST FIRST.RMC)
                                  (ALONE ALONE.RMC)
                                  NIL))))

(ACCESSFNS ESCAPES ((KEY (SELECTC DATUM
                                 (ESC.RME 'ESCQUOTE)
                                 (NOESC.RME 'NOESCQUOTE)
                                 NIL))
                        (VAL (SELECTQ DATUM
                                 ((ESCQUOTE ESC) 
                                      ESC.RME)
                                 ((NOESCQUOTE NOESC) 
                                      NOESC.RME)
                                 NIL))))

(ACCESSFNS WAKEUPS ((KEY (SELECTC DATUM
                                 (IMMEDIATE.RMW 'IMMEDIATE)
                                 (NONIMMEDIATE.RMW 
                                      'NONIMMEDIATE)
                                 NIL))
                        (VAL (SELECTQ DATUM
                                 ((IMMEDIATE IMMED WAKEUP) 
                                      IMMEDIATE.RMW)
                                 ((NONIMMEDIATE NONIMMED NOWAKEUP) 
                                      NONIMMEDIATE.RMW)
                                 NIL))))
)

(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS \GETREADMACRODEF  MACRO
   ((C TBL)
    (GETHASH C (fetch READMACRODEFS of TBL))))

(PUTPROPS \GTREADTABLE  MACRO
   [ARGS (COND
            [(LITATOM (CAR ARGS))
             (SUBPAIR '(X . FLG)
                    ARGS
                    '(SELECTQ X
                         ((NIL T) 
                              (\DTEST *READTABLE* 'READTABLEP))
                         (\GTREADTABLE1 X . FLG]
            (T 'IGNOREMACRO])

(PUTPROPS \GTREADTABLE1 DMACRO [ARGS (COND
                                                [(NULL (CDR ARGS))
                                                 (LIST '\DTEST (CAR ARGS)
                                                       ''READTABLEP]
                                                (T 'IGNOREMACRO])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ MACROBIT 10Q)

(RPAQQ BREAKBIT 20Q)

(RPAQQ STOPATOMBIT 40Q)

(RPAQQ ESCAPEBIT 100Q)

(RPAQQ INNERESCAPEBIT 4)


(CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
)

(RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
                          (WAKEUPMASK (LOGOR MACROBIT 2))))
(DECLARE%: EVAL@COMPILE 

(RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))

(RPAQ WAKEUPMASK (LOGOR MACROBIT 2))


(CONSTANTS (CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
       (WAKEUPMASK (LOGOR MACROBIT 2)))
)

(RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
                              (FIRST.RMC (LOGOR MACROBIT 0))
                              (ALONE.RMC (LOGOR MACROBIT 1))))
(DECLARE%: EVAL@COMPILE 

(RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))

(RPAQ FIRST.RMC (LOGOR MACROBIT 0))

(RPAQ ALONE.RMC (LOGOR MACROBIT 1))


(CONSTANTS (ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
       (FIRST.RMC (LOGOR MACROBIT 0))
       (ALONE.RMC (LOGOR MACROBIT 1)))
)

(RPAQQ READCLASSES
       ((OTHER.RC 0)
        (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0))
        (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))
        (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))
        (LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))
        (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))
        (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))
        (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))
        (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6))
        (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7))
        (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))
(DECLARE%: EVAL@COMPILE 

(RPAQQ OTHER.RC 0)

(RPAQ SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0))

(RPAQ BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))

(RPAQ STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))

(RPAQ LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))

(RPAQ RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))

(RPAQ LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))

(RPAQ RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))

(RPAQ ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6))

(RPAQ MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7))

(RPAQ PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))


(CONSTANTS (OTHER.RC 0)
       (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0))
       (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))
       (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))
       (LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))
       (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))
       (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))
       (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))
       (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6))
       (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7))
       (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)))
)

(RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2))
                             (NONIMMEDIATE.RMW (LOGOR MACROBIT 0))))
(DECLARE%: EVAL@COMPILE 

(RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2))

(RPAQ NONIMMEDIATE.RMW (LOGOR MACROBIT 0))


(CONSTANTS (IMMEDIATE.RMW (LOGOR MACROBIT 2))
       (NONIMMEDIATE.RMW (LOGOR MACROBIT 0)))
)

(RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT)
                             (NOESC.RME 0)))
(DECLARE%: EVAL@COMPILE 

(RPAQ ESC.RME ESCAPEBIT)

(RPAQQ NOESC.RME 0)


(CONSTANTS (ESC.RME ESCAPEBIT)
       (NOESC.RME 0))
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT))
                         (ESCQUOTE (BITTEST DATUM ESCAPEBIT))
                         (STOPATOM (BITTEST DATUM STOPATOMBIT))
                         (INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT)))
                         (MACROCONTEXT (LOGAND DATUM CONTEXTMASK))
                         (MACROP (BITTEST DATUM MACROBIT))
                         (WAKEUP (LOGAND DATUM WAKEUPMASK))
                         (BREAK (BITTEST DATUM BREAKBIT))))

(RECORD READMACRODEF (MACROTYPE . MACROFN))

(DATATYPE READTABLEP ((READSA POINTER)                   (* ; 
                                                         "A CHARTABLE defining syntax of each char")
                          (READMACRODEFS POINTER)            (* ; 
                                      "A hash table associating macro chars with macro definitions")
                          (READMACROFLG FLAG)                (* ; 
           "True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")
                          (ESCAPEFLG FLAG)                   (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)")
                          (COMMONLISP FLAG)                  (* ; 
           "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
                          (NUMBERBASE BITS 5)                (* ; "Not used")
                          (CASEINSENSITIVE FLAG)             (* ; 
                         "If true, unescaped lowercase chars are converted to uppercase in symbols")
                          (COMMONNUMSYNTAX FLAG)             (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers")
                          (USESILPACKAGE FLAG)               (* ; 
                                   "If true, IL:READ ignores *PACKAGE* and reads in the IL package")
                          (NIL 5 FLAG)
                          (DISPATCHMACRODEFS POINTER)        (* ; 
                                 "An a-list of dispatching macro char and its dispatch definitions")
                          (HASHMACROCHAR BYTE)               (* ; 
                              "The character code used in this read table for the # dispatch macro")
                          (ESCAPECHAR BYTE)                  (* ; 
                                     "The character code used in this read table for single escape")
                          (MULTESCAPECHAR BYTE)              (* ; 
                                   "The character code used in this read table for multiple escape")
                          (PACKAGECHAR BYTE)                 (* ; 
                                 "The character code used in this read table for package delimiter")
                          (READTBLNAME POINTER)              (* ; 
                                                          "The canonical 'name' of this read table")
                          )
                         READSA _ (create CHARTABLE))
)

(/DECLAREDATATYPE 'READTABLEP
       '(POINTER POINTER FLAG FLAG FLAG (BITS 5)
               FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)
       '((READTABLEP 0 POINTER)
         (READTABLEP 2 POINTER)
         (READTABLEP 2 (FLAGBITS . 0))
         (READTABLEP 2 (FLAGBITS . 20Q))
         (READTABLEP 2 (FLAGBITS . 40Q))
         (READTABLEP 4 (BITS . 4))
         (READTABLEP 2 (FLAGBITS . 60Q))
         (READTABLEP 0 (FLAGBITS . 0))
         (READTABLEP 0 (FLAGBITS . 20Q))
         (READTABLEP 0 (FLAGBITS . 40Q))
         (READTABLEP 0 (FLAGBITS . 60Q))
         (READTABLEP 4 (FLAGBITS . 120Q))
         (READTABLEP 4 (FLAGBITS . 140Q))
         (READTABLEP 4 (FLAGBITS . 160Q))
         (READTABLEP 6 POINTER)
         (READTABLEP 5 (BITS . 7))
         (READTABLEP 5 (BITS . 207Q))
         (READTABLEP 4 (BITS . 207Q))
         (READTABLEP 10Q (BITS . 7))
         (READTABLEP 12Q POINTER))
       '14Q)

(* "END EXPORTED DEFINITIONS")


(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE)
)
)

(/DECLAREDATATYPE 'READTABLEP
       '(POINTER POINTER FLAG FLAG FLAG (BITS 5)
               FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)
       '((READTABLEP 0 POINTER)
         (READTABLEP 2 POINTER)
         (READTABLEP 2 (FLAGBITS . 0))
         (READTABLEP 2 (FLAGBITS . 20Q))
         (READTABLEP 2 (FLAGBITS . 40Q))
         (READTABLEP 4 (BITS . 4))
         (READTABLEP 2 (FLAGBITS . 60Q))
         (READTABLEP 0 (FLAGBITS . 0))
         (READTABLEP 0 (FLAGBITS . 20Q))
         (READTABLEP 0 (FLAGBITS . 40Q))
         (READTABLEP 0 (FLAGBITS . 60Q))
         (READTABLEP 4 (FLAGBITS . 120Q))
         (READTABLEP 4 (FLAGBITS . 140Q))
         (READTABLEP 4 (FLAGBITS . 160Q))
         (READTABLEP 6 POINTER)
         (READTABLEP 5 (BITS . 7))
         (READTABLEP 5 (BITS . 207Q))
         (READTABLEP 4 (BITS . 207Q))
         (READTABLEP 10Q (BITS . 7))
         (READTABLEP 12Q POINTER))
       '14Q)

(RPAQ? \READTABLEHASH )
(DEFINEQ

(\ATBLSET
  [LAMBDA NIL                                           (* ; "Edited 20-Apr-2018 17:34 by rmk:")
                                                             (* ; "Edited  3-Dec-86 18:07 by Pavel")
    (DECLARE (GLOBALVARS \ORIGREADTABLE \ORIGTERMTABLE))
    (COND
       ((NULL (BOUNDP '\PRIMREADTABLE))
        (initrecord CHARTABLE)

        (* ;; "Read tables")

        (* ;; "RMK:  If reloading, don't smash an existing hash table")

        [OR (HARRAYP \READTABLEHASH)
            (SETQ \READTABLEHASH (HASHARRAY 24Q NIL (FUNCTION STRING-EQUAL-HASHBITS)
                                        (FUNCTION STRING-EQUAL]
        (LET (TRDTBL NEW-IL-RDTBL)
             (PROGN                                          (* ; "The ORIG read table")
                    (SETQ \ORIGREADTABLE (\ORIGREADTABLE))
                    (READTABLEPROP \ORIGREADTABLE 'NAME 'ORIG))
             (PROGN                                          (* ; 
                            "The old Interlisp T read table.  May not have a use for this any more")
                    (SETQ TRDTBL (COPYREADTABLE \ORIGREADTABLE))
                    (SETSYNTAX (CHARCODE "|")
                           '(MACRO READVBAR)
                           TRDTBL)
                    (SETSYNTAX (CHARCODE "`")
                           '(MACRO FIRST READBQUOTE)
                           TRDTBL)
                    (SETSYNTAX (CHARCODE ",")
                           '(MACRO FIRST READBQUOTECOMMA)
                           TRDTBL)
                    (SETSYNTAX (CHARCODE "'")
                           '(MACRO FIRST READQUOTE)
                           TRDTBL)
                    (READTABLEPROP TRDTBL 'NAME "OLD-INTERLISP-T")
                    (PROGN                                   (* ; "Temporary")
                           (SETTOPVAL '%#CURRENTRDTBL# TRDTBL)))
             (PROGN                                          (* ; "The old FILERDTBL")
                    (SETQ FILERDTBL (COPYREADTABLE \ORIGREADTABLE))
                    (SETSYNTAX (CHARCODE "|")
                           TRDTBL FILERDTBL)
                    (READTABLEPROP FILERDTBL 'NAME "OLD-INTERLISP-FILE")
                    (SETQ *OLD-INTERLISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT
                                                                  REREADTABLE _ FILERDTBL
                                                                  REBASE _ 12Q))
                                                             (* ; 
                                                           "need this to read files in the loadup")
                    )
             (PROGN (SETQ NEW-IL-RDTBL (COPYREADTABLE TRDTBL))
                                                             (* ; 
                                                "The new Interlisp read table is more common lispy")
                    (READTABLEPROP NEW-IL-RDTBL 'MULTIPLE-ESCAPECHAR (CHARCODE "|"))
                    (READTABLEPROP NEW-IL-RDTBL 'HASHMACROCHAR (CHARCODE "#"))
                    (SET-DEFAULT-HASHMACRO-SETTINGS NEW-IL-RDTBL)
                    (READTABLEPROP NEW-IL-RDTBL 'COMMONNUMSYNTAX T)
                    (READTABLEPROP NEW-IL-RDTBL 'USESILPACKAGE NIL)
                    (READTABLEPROP NEW-IL-RDTBL 'NAME "INTERLISP")
                    (for I from 1 to 32Q do (SETSYNTAX I 'SEPRCHAR FILERDTBL) 
                                                             (* ; "Make font switch chars seprs")
                                                           (SETSYNTAX I 'SEPRCHAR NEW-IL-RDTBL))
                    (SETQ *READTABLE* NEW-IL-RDTBL))

             (* ;; "Make ^Y like #. in the old T readtable and the new INTERLISP one.")

             (SETSYNTAX (CHARCODE ^Y)
                    '[MACRO ALWAYS (LAMBDA (FILE RDTBL)
                                     (EVAL (READ FILE RDTBL]
                    TRDTBL)
             (SETSYNTAX (CHARCODE ^Y)
                    TRDTBL NEW-IL-RDTBL)
             (DEFPRINT 'READTABLEP '\READTABLEP.DEFPRINT))

        (* ;; "Terminal tables")

        (SETQ \ORIGTERMTABLE (\ORIGTERMTABLE))
        (SETQ \PRIMTERMTABLE (COPYTERMTABLE \ORIGTERMTABLE))
        (SETQ \PRIMTERMSA (fetch TERMSA of \PRIMTERMTABLE))
        (PUTD '\ATBLSET)
        (PUTD '\ORIGTERMTABLE)
        NIL])
)

(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER)
       '((READER-ENVIRONMENT 0 POINTER)
         (READER-ENVIRONMENT 2 POINTER)
         (READER-ENVIRONMENT 4 POINTER)
         (READER-ENVIRONMENT 6 POINTER))
       '10Q)



(* ; "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")

(DEFINEQ

(MAKE-READER-ENVIRONMENT
  [LAMBDA (PACKAGE READTABLE BASE)                           (* ; "Edited 18-Dec-86 18:28 by bvm:")
    (create READER-ENVIRONMENT
           REPACKAGE _ (COND
                          (PACKAGE (\DTEST PACKAGE 'PACKAGE))
                          (T *PACKAGE*))
           REREADTABLE _ (COND
                            (READTABLE (\DTEST READTABLE 'READTABLEP))
                            (T *READTABLE*))
           REBASE _ (COND
                       (BASE (\CHECKRADIX BASE))
                       (T *PRINT-BASE*])

(EQUAL-READER-ENVIRONMENT
  [LAMBDA (ENV1 ENV2)                                        (* bvm%: "31-Jul-86 12:54")
    (AND (EQ (fetch (READER-ENVIRONMENT REREADTABLE) of ENV1)
             (fetch (READER-ENVIRONMENT REREADTABLE) of ENV2))
         (EQ (fetch (READER-ENVIRONMENT REPACKAGE) of ENV1)
             (fetch (READER-ENVIRONMENT REPACKAGE) of ENV2))
         (EQ (fetch (READER-ENVIRONMENT REBASE) of ENV1)
             (fetch (READER-ENVIRONMENT REBASE) of ENV2])

(SET-READER-ENVIRONMENT
  [LAMBDA (ENV)                                              (* bvm%: "28-Aug-86 17:44")

(* ;;; "Sets the reader environment variables from ENV.  Should usually only be called inside a WITH-READER-ENVIRONMENT.")

    [SETQ *PACKAGE* (ffetch REPACKAGE of (\DTEST ENV 'READER-ENVIRONMENT]
    (SETQ *READTABLE* (ffetch REREADTABLE of ENV))
    (SETQ *READ-BASE* (SETQ *PRINT-BASE* (ffetch REBASE of ENV)))
    ENV])
)

(RPAQ? *LISP-PACKAGE* )

(RPAQ? *INTERLISP-PACKAGE* )

(RPAQ? *KEYWORD-PACKAGE* )
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\ATBLSET)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA READTABLEPROP)
)
(PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3706Q 3711Q 
3742Q))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (44105Q 67336Q (GETSYNTAX 44117Q . 55046Q) (SETSYNTAX 55050Q . 57135Q) (SYNTAXP 57137Q
 . 62543Q) (\COPYSYNTAX 62545Q . 63630Q) (\GETCHARCODE 63632Q . 64276Q) (\SETFATSYNCODE 64300Q . 
66453Q) (\MAPCHARTABLE 66455Q . 67334Q)) (67377Q 124165Q (CONTROL 67411Q . 70011Q) (COPYTERMTABLE 
70013Q . 70455Q) (DELETECONTROL 70457Q . 75277Q) (GETDELETECONTROL 75301Q . 77207Q) (ECHOCHAR 77211Q
 . 102107Q) (ECHOCONTROL 102111Q . 103031Q) (ECHOMODE 103033Q . 103425Q) (GETECHOMODE 103427Q . 
103677Q) (GETCONTROL 103701Q . 104153Q) (GETTERMTABLE 104155Q . 104260Q) (RAISE 104262Q . 105104Q) (
GETRAISE 105106Q . 105354Q) (RESETTERMTABLE 105356Q . 107456Q) (SETTERMTABLE 107460Q . 110147Q) (
TERMTABLEP 110151Q . 110416Q) (\GETTERMSYNTAX 110420Q . 111027Q) (\GTTERMTABLE 111031Q . 111555Q) (
\ORIGTERMTABLE 111557Q . 120420Q) (\SETTERMSYNTAX 120422Q . 121621Q) (\TERMCLASSTOCODE 121623Q . 
122504Q) (\TERMCODETOCLASS 122506Q . 123315Q) (\LITCHECK 123317Q . 124163Q)) (131156Q 210103Q (
COPYREADTABLE 131170Q . 131502Q) (FIND-READTABLE 131504Q . 131733Q) (IN-READTABLE 131735Q . 132201Q) (
ESCAPE 132203Q . 132604Q) (GETBRK 132606Q . 133024Q) (GETREADTABLE 133026Q . 133237Q) (GETSEPR 133241Q
 . 133457Q) (READMACROS 133461Q . 134074Q) (READTABLEP 134076Q . 134345Q) (READTABLEPROP 134347Q . 
146545Q) (RESETREADTABLE 146547Q . 157034Q) (SETBRK 157036Q . 162142Q) (SETREADTABLE 162144Q . 162431Q
) (SETSEPR 162433Q . 165433Q) (\GETREADSYNTAX 165435Q . 172615Q) (\GTREADTABLE 172617Q . 173164Q) (
\GTREADTABLE1 173166Q . 173572Q) (\ORIGREADTABLE 173574Q . 177413Q) (\READCLASSTOCODE 177415Q . 
200324Q) (\SETMACROSYNTAX 200326Q . 203742Q) (\SETREADSYNTAX 203744Q . 206027Q) (\READTABLEP.DEFPRINT 
206031Q . 210101Q)) (241125Q 251763Q (\ATBLSET 241137Q . 251761Q)) (252522Q 255615Q (
MAKE-READER-ENVIRONMENT 252534Q . 253622Q) (EQUAL-READER-ENVIRONMENT 253624Q . 254653Q) (
SET-READER-ENVIRONMENT 254655Q . 255613Q)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Feb-2021 22:55:58" {DSK}<home>larry>ilisp>medley>sources>ATBL.;9 257317Q

      changes to%:  (FNS RESETREADTABLE)

      previous date%: "20-Apr-2018 17:35:56" {DSK}<home>larry>ilisp>medley>sources>ATBL.;8)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1993, 2018, 2021 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT ATBLCOMS)

(RPAQQ ATBLCOMS
       [(E (RESETSAVE (RADIX 8)))
        (COMS                                                (* ; 
                                                      "Common features of read and terminal tables")
              (DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE)
                                         (RECORDS CHARTABLE))
                     (CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
                     (MACROS \CREATENSCHARHASH))
              (FNS GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE \MAPCHARTABLE)
              )
        (COMS                                                (* ; "terminal tables")
              (FNS CONTROL COPYTERMTABLE DELETECONTROL GETDELETECONTROL ECHOCHAR ECHOCONTROL ECHOMODE
                   GETECHOMODE GETCONTROL GETTERMTABLE RAISE GETRAISE RESETTERMTABLE SETTERMTABLE 
                   TERMTABLEP \GETTERMSYNTAX \GTTERMTABLE \ORIGTERMTABLE \SETTERMSYNTAX 
                   \TERMCLASSTOCODE \TERMCODETOCLASS \LITCHECK)
              (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * CCECHOMODES)
                                         (CONSTANTS * TERMCLASSES)
                                         (RECORDS TERMCODE TERMTABLEP)))
              (INITRECORDS TERMTABLEP))
        (COMS                                                (* ; "read tables")
              (FNS COPYREADTABLE FIND-READTABLE IN-READTABLE ESCAPE GETBRK GETREADTABLE GETSEPR 
                   READMACROS READTABLEP READTABLEPROP RESETREADTABLE SETBRK SETREADTABLE SETSEPR 
                   \GETREADSYNTAX \GTREADTABLE \GTREADTABLE1 \ORIGREADTABLE \READCLASSTOCODE 
                   \SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT)
              (PROP ARGNAMES READTABLEPROP)
              (DECLARE%: EVAL@COMPILE DONTCOPY               (* ; 
                             "READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's")
                                                             (* ; 
                                                    "OTHER must be zero because of initialization.")
                     [VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS
                                                               (FUNCTION (LAMBDA
                                                                          (PAIR)
                                                                          (LIST (PACK* (CAR PAIR)
                                                                                       ".RC")
                                                                                (CADR PAIR]
                     (MACROS \COMPUTED.FORM)
                                                             (* ; 
                                                          "This macro ought to be official somehow")
                     (RECORDS CONTEXTS ESCAPES WAKEUPS)
                     (EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1)
                            (CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
                            (CONSTANTS * READCODEMASKS)
                            (CONSTANTS * READMACROCONTEXTS)
                            (CONSTANTS * READCLASSES)
                            (CONSTANTS * READMACROWAKEUPS)
                            (CONSTANTS * READMACROESCAPES)
                            (RECORDS READCODE READMACRODEF READTABLEP))
                     (GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE))
              (INITRECORDS READTABLEP))
        [COMS (INITVARS (\READTABLEHASH))
              (FNS \ATBLSET)
              (INITRECORDS READER-ENVIRONMENT)
                                                             (* ; 
            "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")
              (FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT)
              (INITVARS (*LISP-PACKAGE*)
                     (*INTERLISP-PACKAGE*)
                     (*KEYWORD-PACKAGE*))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\ATBLSET]
        (LOCALVARS . T)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA READTABLEPROP])



(* ; "Common features of read and terminal tables")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR)
                                    (CHECK (type? CHARTABLE TABLE))
                                                             (* ; 
                                                       "0 is either NONE.TC, REAL.CCE, or OTHER.RC")
                                    (COND
                                       ((IGREATERP CHAR \MAXTHINCHAR)
                                        (OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE)
                                                 (GETHASH CHAR (fetch (CHARTABLE NSCHARHASH)
                                                                  of TABLE)))
                                            0))
                                       (T (\GETBASEBYTE TABLE CHAR])

(PUTPROPS \SETSYNCODE DMACRO [LAMBDA (TABLE CHAR CODE)
                                       (CHECK (type? CHARTABLE TABLE))
                                                             (* ; 
                                                           "0 is REAL.CCE, NONE.TC, OTHER.RC")
                                       (COND
                                          ((ILEQ CHAR \MAXTHINCHAR)
                                           (\PUTBASEBYTE TABLE CHAR CODE))
                                          (T (\SETFATSYNCODE TABLE CHAR CODE])
)
(DECLARE%: EVAL@COMPILE

(DATATYPE CHARTABLE ((CHARSET0 400Q BYTE)
                         (NSCHARHASH FULLPOINTER)))
)

(/DECLAREDATATYPE 'CHARTABLE
       '(BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE 
              FULLPOINTER)
       '((CHARTABLE 0 (BITS . 7))
         (CHARTABLE 0 (BITS . 207Q))
         (CHARTABLE 1 (BITS . 7))
         (CHARTABLE 1 (BITS . 207Q))
         (CHARTABLE 2 (BITS . 7))
         (CHARTABLE 2 (BITS . 207Q))
         (CHARTABLE 3 (BITS . 7))
         (CHARTABLE 3 (BITS . 207Q))
         (CHARTABLE 4 (BITS . 7))
         (CHARTABLE 4 (BITS . 207Q))
         (CHARTABLE 5 (BITS . 7))
         (CHARTABLE 5 (BITS . 207Q))
         (CHARTABLE 6 (BITS . 7))
         (CHARTABLE 6 (BITS . 207Q))
         (CHARTABLE 7 (BITS . 7))
         (CHARTABLE 7 (BITS . 207Q))
         (CHARTABLE 10Q (BITS . 7))
         (CHARTABLE 10Q (BITS . 207Q))
         (CHARTABLE 11Q (BITS . 7))
         (CHARTABLE 11Q (BITS . 207Q))
         (CHARTABLE 12Q (BITS . 7))
         (CHARTABLE 12Q (BITS . 207Q))
         (CHARTABLE 13Q (BITS . 7))
         (CHARTABLE 13Q (BITS . 207Q))
         (CHARTABLE 14Q (BITS . 7))
         (CHARTABLE 14Q (BITS . 207Q))
         (CHARTABLE 15Q (BITS . 7))
         (CHARTABLE 15Q (BITS . 207Q))
         (CHARTABLE 16Q (BITS . 7))
         (CHARTABLE 16Q (BITS . 207Q))
         (CHARTABLE 17Q (BITS . 7))
         (CHARTABLE 17Q (BITS . 207Q))
         (CHARTABLE 20Q (BITS . 7))
         (CHARTABLE 20Q (BITS . 207Q))
         (CHARTABLE 21Q (BITS . 7))
         (CHARTABLE 21Q (BITS . 207Q))
         (CHARTABLE 22Q (BITS . 7))
         (CHARTABLE 22Q (BITS . 207Q))
         (CHARTABLE 23Q (BITS . 7))
         (CHARTABLE 23Q (BITS . 207Q))
         (CHARTABLE 24Q (BITS . 7))
         (CHARTABLE 24Q (BITS . 207Q))
         (CHARTABLE 25Q (BITS . 7))
         (CHARTABLE 25Q (BITS . 207Q))
         (CHARTABLE 26Q (BITS . 7))
         (CHARTABLE 26Q (BITS . 207Q))
         (CHARTABLE 27Q (BITS . 7))
         (CHARTABLE 27Q (BITS . 207Q))
         (CHARTABLE 30Q (BITS . 7))
         (CHARTABLE 30Q (BITS . 207Q))
         (CHARTABLE 31Q (BITS . 7))
         (CHARTABLE 31Q (BITS . 207Q))
         (CHARTABLE 32Q (BITS . 7))
         (CHARTABLE 32Q (BITS . 207Q))
         (CHARTABLE 33Q (BITS . 7))
         (CHARTABLE 33Q (BITS . 207Q))
         (CHARTABLE 34Q (BITS . 7))
         (CHARTABLE 34Q (BITS . 207Q))
         (CHARTABLE 35Q (BITS . 7))
         (CHARTABLE 35Q (BITS . 207Q))
         (CHARTABLE 36Q (BITS . 7))
         (CHARTABLE 36Q (BITS . 207Q))
         (CHARTABLE 37Q (BITS . 7))
         (CHARTABLE 37Q (BITS . 207Q))
         (CHARTABLE 40Q (BITS . 7))
         (CHARTABLE 40Q (BITS . 207Q))
         (CHARTABLE 41Q (BITS . 7))
         (CHARTABLE 41Q (BITS . 207Q))
         (CHARTABLE 42Q (BITS . 7))
         (CHARTABLE 42Q (BITS . 207Q))
         (CHARTABLE 43Q (BITS . 7))
         (CHARTABLE 43Q (BITS . 207Q))
         (CHARTABLE 44Q (BITS . 7))
         (CHARTABLE 44Q (BITS . 207Q))
         (CHARTABLE 45Q (BITS . 7))
         (CHARTABLE 45Q (BITS . 207Q))
         (CHARTABLE 46Q (BITS . 7))
         (CHARTABLE 46Q (BITS . 207Q))
         (CHARTABLE 47Q (BITS . 7))
         (CHARTABLE 47Q (BITS . 207Q))
         (CHARTABLE 50Q (BITS . 7))
         (CHARTABLE 50Q (BITS . 207Q))
         (CHARTABLE 51Q (BITS . 7))
         (CHARTABLE 51Q (BITS . 207Q))
         (CHARTABLE 52Q (BITS . 7))
         (CHARTABLE 52Q (BITS . 207Q))
         (CHARTABLE 53Q (BITS . 7))
         (CHARTABLE 53Q (BITS . 207Q))
         (CHARTABLE 54Q (BITS . 7))
         (CHARTABLE 54Q (BITS . 207Q))
         (CHARTABLE 55Q (BITS . 7))
         (CHARTABLE 55Q (BITS . 207Q))
         (CHARTABLE 56Q (BITS . 7))
         (CHARTABLE 56Q (BITS . 207Q))
         (CHARTABLE 57Q (BITS . 7))
         (CHARTABLE 57Q (BITS . 207Q))
         (CHARTABLE 60Q (BITS . 7))
         (CHARTABLE 60Q (BITS . 207Q))
         (CHARTABLE 61Q (BITS . 7))
         (CHARTABLE 61Q (BITS . 207Q))
         (CHARTABLE 62Q (BITS . 7))
         (CHARTABLE 62Q (BITS . 207Q))
         (CHARTABLE 63Q (BITS . 7))
         (CHARTABLE 63Q (BITS . 207Q))
         (CHARTABLE 64Q (BITS . 7))
         (CHARTABLE 64Q (BITS . 207Q))
         (CHARTABLE 65Q (BITS . 7))
         (CHARTABLE 65Q (BITS . 207Q))
         (CHARTABLE 66Q (BITS . 7))
         (CHARTABLE 66Q (BITS . 207Q))
         (CHARTABLE 67Q (BITS . 7))
         (CHARTABLE 67Q (BITS . 207Q))
         (CHARTABLE 70Q (BITS . 7))
         (CHARTABLE 70Q (BITS . 207Q))
         (CHARTABLE 71Q (BITS . 7))
         (CHARTABLE 71Q (BITS . 207Q))
         (CHARTABLE 72Q (BITS . 7))
         (CHARTABLE 72Q (BITS . 207Q))
         (CHARTABLE 73Q (BITS . 7))
         (CHARTABLE 73Q (BITS . 207Q))
         (CHARTABLE 74Q (BITS . 7))
         (CHARTABLE 74Q (BITS . 207Q))
         (CHARTABLE 75Q (BITS . 7))
         (CHARTABLE 75Q (BITS . 207Q))
         (CHARTABLE 76Q (BITS . 7))
         (CHARTABLE 76Q (BITS . 207Q))
         (CHARTABLE 77Q (BITS . 7))
         (CHARTABLE 77Q (BITS . 207Q))
         (CHARTABLE 100Q (BITS . 7))
         (CHARTABLE 100Q (BITS . 207Q))
         (CHARTABLE 101Q (BITS . 7))
         (CHARTABLE 101Q (BITS . 207Q))
         (CHARTABLE 102Q (BITS . 7))
         (CHARTABLE 102Q (BITS . 207Q))
         (CHARTABLE 103Q (BITS . 7))
         (CHARTABLE 103Q (BITS . 207Q))
         (CHARTABLE 104Q (BITS . 7))
         (CHARTABLE 104Q (BITS . 207Q))
         (CHARTABLE 105Q (BITS . 7))
         (CHARTABLE 105Q (BITS . 207Q))
         (CHARTABLE 106Q (BITS . 7))
         (CHARTABLE 106Q (BITS . 207Q))
         (CHARTABLE 107Q (BITS . 7))
         (CHARTABLE 107Q (BITS . 207Q))
         (CHARTABLE 110Q (BITS . 7))
         (CHARTABLE 110Q (BITS . 207Q))
         (CHARTABLE 111Q (BITS . 7))
         (CHARTABLE 111Q (BITS . 207Q))
         (CHARTABLE 112Q (BITS . 7))
         (CHARTABLE 112Q (BITS . 207Q))
         (CHARTABLE 113Q (BITS . 7))
         (CHARTABLE 113Q (BITS . 207Q))
         (CHARTABLE 114Q (BITS . 7))
         (CHARTABLE 114Q (BITS . 207Q))
         (CHARTABLE 115Q (BITS . 7))
         (CHARTABLE 115Q (BITS . 207Q))
         (CHARTABLE 116Q (BITS . 7))
         (CHARTABLE 116Q (BITS . 207Q))
         (CHARTABLE 117Q (BITS . 7))
         (CHARTABLE 117Q (BITS . 207Q))
         (CHARTABLE 120Q (BITS . 7))
         (CHARTABLE 120Q (BITS . 207Q))
         (CHARTABLE 121Q (BITS . 7))
         (CHARTABLE 121Q (BITS . 207Q))
         (CHARTABLE 122Q (BITS . 7))
         (CHARTABLE 122Q (BITS . 207Q))
         (CHARTABLE 123Q (BITS . 7))
         (CHARTABLE 123Q (BITS . 207Q))
         (CHARTABLE 124Q (BITS . 7))
         (CHARTABLE 124Q (BITS . 207Q))
         (CHARTABLE 125Q (BITS . 7))
         (CHARTABLE 125Q (BITS . 207Q))
         (CHARTABLE 126Q (BITS . 7))
         (CHARTABLE 126Q (BITS . 207Q))
         (CHARTABLE 127Q (BITS . 7))
         (CHARTABLE 127Q (BITS . 207Q))
         (CHARTABLE 130Q (BITS . 7))
         (CHARTABLE 130Q (BITS . 207Q))
         (CHARTABLE 131Q (BITS . 7))
         (CHARTABLE 131Q (BITS . 207Q))
         (CHARTABLE 132Q (BITS . 7))
         (CHARTABLE 132Q (BITS . 207Q))
         (CHARTABLE 133Q (BITS . 7))
         (CHARTABLE 133Q (BITS . 207Q))
         (CHARTABLE 134Q (BITS . 7))
         (CHARTABLE 134Q (BITS . 207Q))
         (CHARTABLE 135Q (BITS . 7))
         (CHARTABLE 135Q (BITS . 207Q))
         (CHARTABLE 136Q (BITS . 7))
         (CHARTABLE 136Q (BITS . 207Q))
         (CHARTABLE 137Q (BITS . 7))
         (CHARTABLE 137Q (BITS . 207Q))
         (CHARTABLE 140Q (BITS . 7))
         (CHARTABLE 140Q (BITS . 207Q))
         (CHARTABLE 141Q (BITS . 7))
         (CHARTABLE 141Q (BITS . 207Q))
         (CHARTABLE 142Q (BITS . 7))
         (CHARTABLE 142Q (BITS . 207Q))
         (CHARTABLE 143Q (BITS . 7))
         (CHARTABLE 143Q (BITS . 207Q))
         (CHARTABLE 144Q (BITS . 7))
         (CHARTABLE 144Q (BITS . 207Q))
         (CHARTABLE 145Q (BITS . 7))
         (CHARTABLE 145Q (BITS . 207Q))
         (CHARTABLE 146Q (BITS . 7))
         (CHARTABLE 146Q (BITS . 207Q))
         (CHARTABLE 147Q (BITS . 7))
         (CHARTABLE 147Q (BITS . 207Q))
         (CHARTABLE 150Q (BITS . 7))
         (CHARTABLE 150Q (BITS . 207Q))
         (CHARTABLE 151Q (BITS . 7))
         (CHARTABLE 151Q (BITS . 207Q))
         (CHARTABLE 152Q (BITS . 7))
         (CHARTABLE 152Q (BITS . 207Q))
         (CHARTABLE 153Q (BITS . 7))
         (CHARTABLE 153Q (BITS . 207Q))
         (CHARTABLE 154Q (BITS . 7))
         (CHARTABLE 154Q (BITS . 207Q))
         (CHARTABLE 155Q (BITS . 7))
         (CHARTABLE 155Q (BITS . 207Q))
         (CHARTABLE 156Q (BITS . 7))
         (CHARTABLE 156Q (BITS . 207Q))
         (CHARTABLE 157Q (BITS . 7))
         (CHARTABLE 157Q (BITS . 207Q))
         (CHARTABLE 160Q (BITS . 7))
         (CHARTABLE 160Q (BITS . 207Q))
         (CHARTABLE 161Q (BITS . 7))
         (CHARTABLE 161Q (BITS . 207Q))
         (CHARTABLE 162Q (BITS . 7))
         (CHARTABLE 162Q (BITS . 207Q))
         (CHARTABLE 163Q (BITS . 7))
         (CHARTABLE 163Q (BITS . 207Q))
         (CHARTABLE 164Q (BITS . 7))
         (CHARTABLE 164Q (BITS . 207Q))
         (CHARTABLE 165Q (BITS . 7))
         (CHARTABLE 165Q (BITS . 207Q))
         (CHARTABLE 166Q (BITS . 7))
         (CHARTABLE 166Q (BITS . 207Q))
         (CHARTABLE 167Q (BITS . 7))
         (CHARTABLE 167Q (BITS . 207Q))
         (CHARTABLE 170Q (BITS . 7))
         (CHARTABLE 170Q (BITS . 207Q))
         (CHARTABLE 171Q (BITS . 7))
         (CHARTABLE 171Q (BITS . 207Q))
         (CHARTABLE 172Q (BITS . 7))
         (CHARTABLE 172Q (BITS . 207Q))
         (CHARTABLE 173Q (BITS . 7))
         (CHARTABLE 173Q (BITS . 207Q))
         (CHARTABLE 174Q (BITS . 7))
         (CHARTABLE 174Q (BITS . 207Q))
         (CHARTABLE 175Q (BITS . 7))
         (CHARTABLE 175Q (BITS . 207Q))
         (CHARTABLE 176Q (BITS . 7))
         (CHARTABLE 176Q (BITS . 207Q))
         (CHARTABLE 177Q (BITS . 7))
         (CHARTABLE 177Q (BITS . 207Q))
         (CHARTABLE 200Q FULLPOINTER))
       '202Q)

(* "END EXPORTED DEFINITIONS")


(DECLARE%: EVAL@COMPILE 

(RPAQQ \NSCHARHASHKEYS 12Q)

(RPAQQ \NSCHARHASHOVERFLOW 1.3)


(CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \CREATENSCHARHASH MACRO (ARGS              (* ; 
                        "added size argument for creation of \ORIGTERMTABLE during initialization.")
                                                (LIST 'HASHARRAY (OR (CAR ARGS)
                                                                     '\NSCHARHASHKEYS)
                                                      '\NSCHARHASHOVERFLOW)))
)
)
(DEFINEQ

(GETSYNTAX
  [LAMBDA (CH TABLE)                                         (* bvm%: " 8-Mar-86 17:22")
    (COND
       [(FIXP (SETQ CH (\GETCHARCODE CH)))
        (COND
           ((type? TERMTABLEP TABLE)
            (\GETTERMSYNTAX CH TABLE))
           (T (\GETREADSYNTAX CH (\GTREADTABLE TABLE T]
       (T (PROG (TEM CHARTBL RESULT)
                (COND
                   ((SETQ TEM (\READCLASSTOCODE CH))
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM VAL)
                                                   (push RESULT KEY]
                           CHARTBL))
                   ((EQ CH 'BREAK)
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((fetch BREAK of VAL)
                                                   (push RESULT KEY]
                           CHARTBL))
                   ((SETQ TEM (\TERMCLASSTOCODE CH))
                    (SETQ CHARTBL (fetch TERMSA of (\GTTERMTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM (fetch TERMCLASS of VAL))
                                                   (push RESULT (PROG1 KEY 
                                                             (* SELECTC TEM ((LIST NONE.TC 
                                                             WORDSEPR.TC) (* ; 
                                                           "Only these classes have multiple members") 
                                                             KEY) (RETURN (CONS KEY)))]
                           CHARTBL))
                   [(FMEMB CH '(MACRO SPLICE INFIX))
                    (PROG [LST (A (fetch READMACRODEFS of (\GTREADTABLE TABLE T]
                          (COND
                             (A [MAPHASH A (FUNCTION (LAMBDA (DEF C)
                                                       (AND (EQ CH (fetch MACROTYPE of DEF))
                                                            (push LST C]
                                (RETURN LST]
                   ((SETQ TEM (fetch (CONTEXTS VAL) of CH))
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM (fetch MACROCONTEXT of VAL))
                                                   (push RESULT KEY]
                           CHARTBL))
                   ((SETQ TEM (fetch (WAKEUPS VAL) of CH))
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM (fetch WAKEUP of VAL))
                                                   (push RESULT KEY]
                           CHARTBL))
                   ((SETQ TEM (fetch (ESCAPES VAL) of CH))
                    (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T)))
                    (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY)
                                               (DECLARE (USEDFREE TEM RESULT))
                                               (COND
                                                  ((EQ TEM (fetch ESCAPE of VAL))
                                                   (push RESULT KEY]
                           CHARTBL))
                   (T (\ILLEGAL.ARG CH)))
                (RETURN RESULT])

(SETSYNTAX
  [LAMBDA (CHAR CLASS TBL)                                   (* rmk%: "20-Nov-84 15:47")
    (OR (FIXP (SETQ CHAR (\GETCHARCODE CHAR)))
        (\ILLEGAL.ARG CHAR))
    [OR (type? READTABLEP TBL)
        (type? TERMTABLEP TBL)
        (SETQ TBL (COND
                     ((OR (type? TERMTABLEP CLASS)
                          (\TERMCLASSTOCODE CLASS))
                      (\GTTERMTABLE TBL))
                     (T (\GTREADTABLE TBL]
    [COND
       ((OR (type? READTABLEP CLASS)
            (type? TERMTABLEP CLASS)
            (SELECTQ CLASS
                ((NIL T ORIG) 
                     T)
                NIL))
        (SETQ CLASS (GETSYNTAX CHAR CLASS)))
       ((FIXP (SETQ CLASS (\GETCHARCODE CLASS)))
        (SETQ CLASS (GETSYNTAX CLASS TBL]
    (COND
       ((type? READTABLEP TBL)
        (PROG1 (\GETREADSYNTAX CHAR TBL)
               (\SETREADSYNTAX CHAR CLASS TBL)))
       (T (PROG1 (\GETTERMSYNTAX CHAR TBL)
                 (\SETTERMSYNTAX CHAR CLASS TBL])

(SYNTAXP
  [LAMBDA (CODE CLASS TABLE)                                 (* rmk%: " 5-JUN-80 22:40")
    (PROG (D)
          (RETURN (COND
                     ((EQ CLASS 'BREAK)
                      (fetch BREAK of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                             CODE)))
                     ((SETQ D (\READCLASSTOCODE CLASS))
                      (EQ D (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                   CODE)))
                     [(SETQ D (\TERMCLASSTOCODE CLASS))
                      (EQ D (fetch TERMCLASS of (\SYNCODE (fetch TERMSA of (\GTTERMTABLE TABLE))
                                                       CODE]
                     [(FMEMB CLASS '(MACRO SPLICE INFIX))
                      (AND (SETQ D (fetch READMACRODEFS of (\GTREADTABLE TABLE)))
                           (EQ CLASS (fetch MACROTYPE of (GETHASH CODE D]
                     [(SETQ D (fetch (CONTEXTS VAL) of CLASS))
                      (EQ D (fetch MACROCONTEXT of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                                          CODE]
                     [(SETQ D (fetch (WAKEUPS VAL) of CLASS))
                      (EQ D (fetch WAKEUP of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                                    CODE]
                     [(SETQ D (fetch (ESCAPES VAL) of CLASS))
                      (EQ D (fetch ESCAPE of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE))
                                                    CODE]
                     (T (\ILLEGAL.ARG CLASS])

(\COPYSYNTAX
  [LAMBDA (A B)                                              (* gbn "15-Sep-85 22:36")
          
          (* ;; "Copies chartable A into chartable B")

    (CHECK (AND (type? CHARTABLE A)
                (type? CHARTABLE B)))
    (\MOVEBYTES A 0 B 0 (ADD1 \MAXTHINCHAR))
    (COND
       ((fetch (CHARTABLE NSCHARHASH) of A)
        (replace (CHARTABLE NSCHARHASH) of B with (REHASH (fetch (CHARTABLE NSCHARHASH) of A)
                                                         (\CREATENSCHARHASH])

(\GETCHARCODE
  [LAMBDA (C)                                                (* rmk%: "20-Nov-84 15:46")
    (COND
       ((AND (NUMBERP C)
             (\CHARCODEP (FIX C)))
        (FIX C))
       ((AND (LITATOM C)
             (EQ 1 (NCHARS C)))
        (CHCON1 C))
       (T C])

(\SETFATSYNCODE
  [LAMBDA (TABLE CHAR CODE)                                  (* bvm%: " 8-Mar-86 17:03")

(* ;;; "Called by \SETSYNCODE macro for fat characters")

    (SETQ TABLE (\DTEST TABLE 'CHARTABLE))                   (* ; 
                                                            "CODE = 0 is REAL.CCE, NONE.TC, OTHER.RC")
    (COND
       ((ILEQ CHAR \MAXTHINCHAR)
        (\PUTBASEBYTE TABLE CHAR CODE))
       ((EQ 0 CODE)
        (COND
           ((fetch (CHARTABLE NSCHARHASH) of TABLE)          (* ; 
                                                "there was already a table here so record the change")
            (PUTHASH CHAR CODE (fetch (CHARTABLE NSCHARHASH) of TABLE)))
           (T                                                (* ; 
               "No hashtable yet, and only the default is being stored, so don't build the hashtable")
              0)))
       (T (PUTHASH CHAR CODE (OR (fetch (CHARTABLE NSCHARHASH) of TABLE)
                                 (replace (CHARTABLE NSCHARHASH) of TABLE with (\CREATENSCHARHASH])

(\MAPCHARTABLE
  [LAMBDA (FN CHARTBL)                                  (* ; "Edited 20-Apr-2018 16:53 by rmk:")
    (for I from 0 to \MAXTHINCHAR do (APPLY* FN (\GETBASEBYTE CHARTBL I)
                                                            I))
    (COND
       ((fetch (CHARTABLE NSCHARHASH) of CHARTBL)
        (MAPHASH (fetch (CHARTABLE NSCHARHASH) of CHARTBL)
               FN])
)



(* ; "terminal tables")

(DEFINEQ

(CONTROL
  [LAMBDA (MODE TTBL)                                        (* rmk%: " 8-FEB-80 11:59")
    (PROG1 (fetch CONTROLFLG of (SETQ TTBL (\GTTERMTABLE TTBL)))
           (replace CONTROLFLG of TTBL with (AND MODE T])

(COPYTERMTABLE
  [LAMBDA (TTBL)                                             (* lmm "14-APR-81 14:27")
    (create TERMTABLEP using (SETQ TTBL (\GTTERMTABLE TTBL T))
                             TERMSA _ (create CHARTABLE using (fetch TERMSA of TTBL])

(DELETECONTROL
  [LAMBDA (TYPE MESSAGE TTBL)                                (* lmm " 1-Jan-85 21:34")
    (PROG [VAL (TBL (\GTTERMTABLE TTBL (NULL MESSAGE]
          (SETQ VAL (SELECTQ TYPE
                        ((ECHO NOECHO) 
                             (PROG1 (fetch DELCHARECHO of TBL)
                                    (replace DELCHARECHO of TBL with TYPE)))
                        (DELCHARECHO (PROG1 (fetch DELCHARECHO of TBL)
                                            (SELECTQ MESSAGE
                                                (NIL         (* ; "Called only to get current value"))
                                                ((ECHO NOECHO) 
                                                     (replace DELCHARECHO of TBL with MESSAGE))
                                                (LISPERROR "ILLEGAL ARG" MESSAGE))))
                        ((LINEDELETE DELETELINE) 
                             [PROG1 (fetch LINEDELETE of TBL)
                                    (AND MESSAGE (replace LINEDELETE of TBL with (\LITCHECK MESSAGE])
                        (1STCHDEL [PROG1 (fetch 1STCHDEL of TBL)
                                         (AND MESSAGE (replace 1STCHDEL of TBL with (\LITCHECK 
                                                                                           MESSAGE])
                        (NTHCHDEL [PROG1 (fetch NTHCHDEL of TBL)
                                         (AND MESSAGE (replace NTHCHDEL of TBL with (\LITCHECK 
                                                                                           MESSAGE])
                        (POSTCHDEL [PROG1 (fetch POSTCHDEL of TBL)
                                          (AND MESSAGE (replace POSTCHDEL of TBL with (\LITCHECK
                                                                                       MESSAGE])
                        (EMPTYCHDEL [PROG1 (fetch EMPTYCHDEL of TBL)
                                           (AND MESSAGE (replace EMPTYCHDEL of TBL
                                                           with (\LITCHECK MESSAGE])
                        (LISPERROR "ILLEGAL ARG" TYPE)))
          (RETURN (COND
                     ((STRINGP VAL)
                      (CONCAT VAL))
                     (T VAL])

(GETDELETECONTROL
  [LAMBDA (TYPE TTBL)                                        (* lmm " 1-Jan-85 21:20")
    (PROG (TBL VAL)
          (SETQ TBL (\GTTERMTABLE TTBL T))
          (SETQ VAL (SELECTQ TYPE
                        ((ECHO NOECHO) 
                             (fetch DELCHARECHO of TBL))
                        (DELCHARECHO (fetch DELCHARECHO of TBL))
                        ((LINEDELETE DELETELINE) 
                             (fetch LINEDELETE of TBL))
                        (1STCHDEL (fetch 1STCHDEL of TBL))
                        (NTHCHDEL (fetch NTHCHDEL of TBL))
                        (POSTCHDEL (fetch POSTCHDEL of TBL))
                        (EMPTYCHDEL (fetch EMPTYCHDEL of TBL))
                        (LISPERROR "ILLEGAL ARG" TYPE)))
          (RETURN (COND
                     ((STRINGP VAL)
                      (CONCAT VAL))
                     (T VAL])

(ECHOCHAR
  [LAMBDA (CHARCODE MODE TTBL)                               (* lmm " 1-Jan-85 21:29")
    (COND
       ((LISTP CHARCODE)
        (for X in CHARCODE do (ECHOCHAR X MODE TTBL)))
       (T (PROG [B (SA (fetch TERMSA of (\GTTERMTABLE TTBL (NULL MODE]
                (RETURN (PROG1 (SELECTC (fetch CCECHO of (SETQ B (\SYNCODE SA CHARCODE)))
                                   (REAL.CCE 'REAL)
                                   (IGNORE.CCE 'IGNORE)
                                   (SIMULATE.CCE 'SIMULATE)
                                   'INDICATE)
                               (AND MODE (\SETSYNCODE SA CHARCODE (create TERMCODE
                                                                     using B CCECHO _
                                                                           (SELECTQ MODE
                                                                               (REAL REAL.CCE)
                                                                               (IGNORE IGNORE.CCE)
                                                                               (SIMULATE SIMULATE.CCE)
                                                                               ((INDICATE UPARROW) 
                                                                                    INDICATE.CCE)
                                                                               (\ILLEGAL.ARG MODE])

(ECHOCONTROL
  [LAMBDA (CHAR MODE TTBL)                                   (* rmk%: "20-Nov-84 15:14")
    (PROG ((C (\GETCHARCODE CHAR)))
          (OR [AND (\THINCHARCODEP C)
                   (OR (ILESSP C 40Q)
                       (AND (IGEQ C (CHARCODE A))
                            (ILEQ C (CHARCODE Z))
                            (SETQ C (IDIFFERENCE C 100Q]
              (\ILLEGAL.ARG C))
          (RETURN (ECHOCHAR C MODE TTBL])

(ECHOMODE
  [LAMBDA (FLG TTBL)                                         (* rmk%: " 8-FEB-80 11:57")
    (PROG1 (fetch ECHOFLG of (SETQ TTBL (\GTTERMTABLE TTBL)))
           (replace ECHOFLG of TTBL with (AND FLG T])

(GETECHOMODE
  [LAMBDA (TTBL)                                             (* lmm " 1-Jan-85 21:21")
    (fetch ECHOFLG of (\GTTERMTABLE TTBL T])

(GETCONTROL
  [LAMBDA (TTBL)                                             (* lmm " 1-Jan-85 21:21")
    (fetch CONTROLFLG of (\GTTERMTABLE TTBL T])

(GETTERMTABLE
  [LAMBDA (TTBL)
    (\GTTERMTABLE TTBL NIL])

(RAISE
  [LAMBDA (FLG TTBL)                                         (* bvm%: "14-Feb-85 00:17")
    (PROG1 (fetch RAISEFLG of (SETQ TTBL (\GTTERMTABLE TTBL)))
           (replace RAISEFLG of TTBL with (COND
                                             ((EQ FLG 0)
                                              0)
                                             (FLG T])

(GETRAISE
  [LAMBDA (TTBL)                                             (* lmm " 1-Jan-85 21:21")
    (fetch RAISEFLG of (\GTTERMTABLE TTBL T])

(RESETTERMTABLE
  [LAMBDA (TTBL FROM)                                        (* lmm "14-APR-81 14:34")
    (PROG ((FR (\GTTERMTABLE FROM T))
           (TT (\GTTERMTABLE TTBL)))
          (\COPYSYNTAX (fetch TERMSA of FR)
                 (fetch TERMSA of TT))
          (replace RAISEFLG of TT with (fetch RAISEFLG of FR))
          (replace DELCHARECHO of TT with (fetch DELCHARECHO of FR))
          (replace LINEDELETE of TT with (fetch LINEDELETE of FR))
          (replace 1STCHDEL of TT with (fetch 1STCHDEL of FR))
          (replace NTHCHDEL of TT with (fetch NTHCHDEL of FR))
          (replace POSTCHDEL of TT with (fetch POSTCHDEL of FR))
          (replace EMPTYCHDEL of TT with (fetch EMPTYCHDEL of FR))
          (replace CONTROLFLG of TT with (fetch CONTROLFLG of FR))
          (replace ECHOFLG of TT with (fetch ECHOFLG of FR))
          (RETURN TT])

(SETTERMTABLE
  [LAMBDA (TBL)                                              (* rmk%: " 8-FEB-80 12:16")
    (PROG1 \PRIMTERMTABLE (SETQ \PRIMTERMSA (fetch TERMSA of (SETQ \PRIMTERMTABLE (\GTTERMTABLE
                                                                                   TBL])

(TERMTABLEP
  [LAMBDA (TTBL)                                             (* rmk%: "20-FEB-80 12:29")
    (AND (type? TERMTABLEP TTBL)
         TTBL])

(\GETTERMSYNTAX
  [LAMBDA (C TBL)                                            (* rmk%: "24-APR-80 09:44")
    (\TERMCODETOCLASS (fetch TERMCLASS of (\SYNCODE (fetch TERMSA of TBL)
                                                 C])

(\GTTERMTABLE
  [LAMBDA (TTBL FLG)                                         (* lmm " 6-MAY-80 20:35")
    (COND
       ((type? TERMTABLEP TTBL)
        TTBL)
       ((NULL TTBL)
        \PRIMTERMTABLE)
       ((AND (EQ TTBL 'ORIG)
             FLG)
        \ORIGTERMTABLE)
       (T (LISPERROR "ILLEGAL TERMINAL TABLE" TTBL])

(\ORIGTERMTABLE
  [LAMBDA NIL                                                (* rrb " 5-Oct-85 10:33")
          
          (* ;; "Creates the original terminal table")
          
          (* ;; "must be created with a hash table big enough to hold all of the indicates in character set 1 because this gets evaluated in the loadup before HASHOVERFLOW is defined.  rrb 5-oct-85")

    (PROG ((TBL (create TERMTABLEP
                       TERMSA _ (create CHARTABLE
                                       NSCHARHASH _ (\CREATENSCHARHASH 454Q))
                       DELCHARECHO _ 'ECHO
                       ECHOFLG _ T
                       LINEDELETE _ "##
"
                       1STCHDEL _ "\"
                       NTHCHDEL _ ""
                       POSTCHDEL _ "\"
                       EMPTYCHDEL _ "##
")))
          (PROGN (\SETTERMSYNTAX (SELECTQ (SYSTEMTYPE)
                                     ((TENEX D) 
                                          (CHARCODE ^A))
                                     ((JERICHO VAX TOPS-20) 
                                          (CHARCODE DEL))
                                     (SHOULDNT))
                        'CHARDELETE TBL)
                 (\SETTERMSYNTAX (CHARCODE ^H)
                        'CHARDELETE TBL)                     (* ; 
                                                         "Added ^H as a CHARDELETE character 9/30/85")
                 (\SETTERMSYNTAX (CHARCODE ^W)
                        'WORDDELETE TBL)
                 (\SETTERMSYNTAX (SELECTQ (SYSTEMTYPE)
                                     ((TENEX D) 
                                          (CHARCODE ^Q))
                                     ((JERICHO VAX) 
                                          (CHARCODE ^U))
                                     (SHOULDNT))
                        'LINEDELETE TBL)
                 (\SETTERMSYNTAX (CHARCODE ^R)
                        'RETYPE TBL)
                 (\SETTERMSYNTAX (CHARCODE ^V)
                        'CTRLV TBL)
                 (\SETTERMSYNTAX (CHARCODE EOL)
                        'WAKEUPCHAR TBL)
                 (for C
                    in (CHARCODE (SPACE TAB ! @ %# $ ~ & * - = + %| { } ^ _ %: ; < > %, %. ? /))
                    do (\SETTERMSYNTAX C 'WORDSEPR TBL)))
          (PROGN (ECHOCHAR (CHARCODE (NULL ^A ^B ^C ^D ^E ^F ^H ^K ^L ^N ^O ^P ^Q ^R ^S ^T ^U ^V ^W 
                                           ^X ^Y ^Z ^\ ^%] ^^))
                        'INDICATE TBL)
                 (ECHOCHAR (CHARCODE (BELL TAB LF CR))
                        'REAL TBL)
                 (SELECTQ (SYSTEMTYPE)
                     (D (ECHOCHAR (CHARCODE (NULL ^A ^W ^Q ^R))
                               'IGNORE TBL)
                        (ECHOCHAR (CHARCODE (BELL TAB ESCAPE LF TENEXEOL))
                               'SIMULATE TBL))
                     (JERICHO (ECHOCHAR [CONSTANT (CONS ERASECHARCODE (CHARCODE (BELL TAB ESCAPE EOL]
                                     'SIMULATE TBL))
                     (VAX (ECHOCHAR (CHARCODE (TAB ESCAPE EOL DEL))
                                 'SIMULATE TBL))
                     NIL))
          (for C from 200Q to \MAXTHINCHAR do (ECHOCHAR C 'REAL TBL))
          (for C from (CHARCODE 1,0) to (CHARCODE 1,377) do (ECHOCHAR C 'INDICATE TBL))
          (RETURN TBL])

(\SETTERMSYNTAX
  [LAMBDA (C CLASS TBL)                                      (* rmk%: "26-Mar-85 23:45")
          
          (* ;; "Changes the terminal syntax class for charcode C.  Unlike Interlisp-10, does not turn off previous characters for CHARDELETE, etc.  classes")

    (\SETSYNCODE (fetch TERMSA of TBL)
           C
           (create TERMCODE using (\SYNCODE (fetch TERMSA of TBL)
                                         C)
                                  TERMCLASS _ (OR (\TERMCLASSTOCODE CLASS)
                                                  (LISPERROR "ILLEGAL ARG" CLASS])

(\TERMCLASSTOCODE
  [LAMBDA (CLASS)                                            (* rmk%: "11-FEB-82 21:24")
    (SELECTQ CLASS
        ((EOL WAKEUPCHAR) 
             EOL.TC)
        (NONE NONE.TC)
        (CHARDELETE CHARDELETE.TC)
        (WORDDELETE WORDDELETE.TC)
        (WORDSEPR WORDSEPR.TC)
        (LINEDELETE LINEDELETE.TC)
        (RETYPE RETYPE.TC)
        ((CTRLV CNTRLV) 
             CTRLV.TC)
        NIL])

(\TERMCODETOCLASS
  [LAMBDA (CODE)                                             (* rmk%: "11-FEB-82 21:24")
    (SELECTC CODE
        (EOL.TC 'EOL)
        (NONE.TC 'NONE)
        (CHARDELETE.TC 'CHARDELETE)
        (WORDDELETE.TC 'WORDDELETE)
        (WORDSEPR.TC 'WORDSEPR)
        (LINEDELETE.TC 'LINEDELETE)
        (RETYPE.TC 'RETYPE)
        (CTRLV.TC 'CNTRLV)
        NIL])

(\LITCHECK
  [LAMBDA (X)                                                (* rmk%: "11-FEB-82 21:26")
    (COND
       ((EQ X 'BACKUP)                                       (* ; 
                                         "Means take terminal/implementation dependent backup action")
        X)
       ((LITATOM X)
        (MKSTRING X))
       ((STRINGP X)
        (CONCAT X))
       (T (\ILLEGAL.ARG X])
)
(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ CCECHOMODES (REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE))
(DECLARE%: EVAL@COMPILE 

(RPAQQ REAL.CCE 0)

(RPAQQ IGNORE.CCE 10Q)

(RPAQQ SIMULATE.CCE 20Q)

(RPAQQ INDICATE.CCE 30Q)


(CONSTANTS REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)
)

(RPAQQ TERMCLASSES (NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC 
                              RETYPE.TC CTRLV.TC))
(DECLARE%: EVAL@COMPILE 

(RPAQQ NONE.TC 0)

(RPAQQ EOL.TC 1)

(RPAQQ CHARDELETE.TC 2)

(RPAQQ WORDDELETE.TC 6)

(RPAQQ WORDSEPR.TC 7)

(RPAQQ LINEDELETE.TC 3)

(RPAQQ RETYPE.TC 4)

(RPAQQ CTRLV.TC 5)


(CONSTANTS NONE.TC EOL.TC CHARDELETE.TC WORDDELETE.TC WORDSEPR.TC LINEDELETE.TC RETYPE.TC CTRLV.TC)
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 30Q))
                         (TERMCLASS (LOGAND DATUM 7)))       (* ; 
                                                  "We assume that values are appropriately shifted")
                        (CREATE (LOGOR CCECHO TERMCLASS)))

(DATATYPE TERMTABLEP (TERMSA RAISEFLG DELCHARECHO LINEDELETE 1STCHDEL NTHCHDEL POSTCHDEL 
                                EMPTYCHDEL (CONTROLFLG FLAG)
                                (ECHOFLG FLAG))
                         TERMSA _ (create CHARTABLE))
)

(/DECLAREDATATYPE 'TERMTABLEP '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG
                                      FLAG)
       '((TERMTABLEP 0 POINTER)
         (TERMTABLEP 2 POINTER)
         (TERMTABLEP 4 POINTER)
         (TERMTABLEP 6 POINTER)
         (TERMTABLEP 10Q POINTER)
         (TERMTABLEP 12Q POINTER)
         (TERMTABLEP 14Q POINTER)
         (TERMTABLEP 16Q POINTER)
         (TERMTABLEP 16Q (FLAGBITS . 0))
         (TERMTABLEP 16Q (FLAGBITS . 20Q)))
       '20Q)

(* "END EXPORTED DEFINITIONS")

)

(/DECLAREDATATYPE 'TERMTABLEP '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG
                                      FLAG)
       '((TERMTABLEP 0 POINTER)
         (TERMTABLEP 2 POINTER)
         (TERMTABLEP 4 POINTER)
         (TERMTABLEP 6 POINTER)
         (TERMTABLEP 10Q POINTER)
         (TERMTABLEP 12Q POINTER)
         (TERMTABLEP 14Q POINTER)
         (TERMTABLEP 16Q POINTER)
         (TERMTABLEP 16Q (FLAGBITS . 0))
         (TERMTABLEP 16Q (FLAGBITS . 20Q)))
       '20Q)



(* ; "read tables")

(DEFINEQ

(COPYREADTABLE
  [LAMBDA (RDTBL)                                            (* rmk%: " 2-FEB-80 12:26")
    (RESETREADTABLE (create READTABLEP)
           (\GTREADTABLE RDTBL T])

(FIND-READTABLE
  [LAMBDA (NAME)                                             (* bvm%: "27-Jul-86 15:53")
    (GETHASH NAME \READTABLEHASH])

(IN-READTABLE
  [LAMBDA (RDTBL)                                            (* bvm%: "27-Jul-86 15:55")
    (SETQ *READTABLE* (\GTREADTABLE RDTBL T])

(ESCAPE
  [LAMBDA (FLG RDTBL)                                        (* rmk%: " 1-FEB-80 13:12")
    (PROG1 (fetch ESCAPEFLG of (SETQ RDTBL (\GTREADTABLE RDTBL)))
           (replace ESCAPEFLG of RDTBL with (NEQ FLG NIL])

(GETBRK
  [LAMBDA (RDTBL)                                            (* rmk%: " 2-MAY-80 17:04")
    (GETSYNTAX 'BREAK RDTBL])

(GETREADTABLE
  [LAMBDA (RDTBL)                                            (* lmm%: 4-FEB-76 3 62Q)
    (\GTREADTABLE RDTBL])

(GETSEPR
  [LAMBDA (RDTBL)                                            (* rmk%: " 2-MAY-80 17:05")
    (GETSYNTAX 'SEPR RDTBL])

(READMACROS
  [LAMBDA (FLG RDTBL)                                        (* rmk%: " 1-FEB-80 13:11")
    (PROG1 (fetch READMACROFLG of (SETQ RDTBL (\GTREADTABLE RDTBL)))
           (replace READMACROFLG of RDTBL with (NEQ FLG NIL])

(READTABLEP
  [LAMBDA (RDTBL)                                            (* rmk%: "20-FEB-80 12:32")
    (AND (type? READTABLEP RDTBL)
         RDTBL])

(READTABLEPROP
  [LAMBDA ARGS                                               (* bvm%: "28-Aug-86 15:28")
    (COND
       ((LESSP ARGS 2)
        (\ILLEGAL.ARG NIL))
       ((GREATERP ARGS 3)
        (\ILLEGAL.ARG (ARG ARGS 4)))
       (T (LET [(RDTBL (\GTREADTABLE (ARG ARGS 1)))
                (NEWVALUEP (EQ ARGS 3))
                (NEWVALUE (AND (EQ ARGS 3)
                               (ARG ARGS 3]
               (SELECTQ (ARG ARGS 2)
                   (NUMBERBASE [PROG1 (fetch (READTABLEP NUMBERBASE) of RDTBL)
                                      (COND
                                         (NEWVALUEP (replace (READTABLEP NUMBERBASE) of RDTBL
                                                       with NEWVALUE])
                   (NAME [LET ((OLDNAME (fetch (READTABLEP READTBLNAME) of RDTBL)))
                              (PROG1 OLDNAME (COND
                                                (NEWVALUEP (COND
                                                              (OLDNAME (REMHASH OLDNAME 
                                                                              \READTABLEHASH)))
                                                       (replace (READTABLEP READTBLNAME) of RDTBL
                                                          with NEWVALUE)
                                                       (PUTHASH NEWVALUE RDTBL \READTABLEHASH])
                   (COMMONLISP [PROG1 (fetch (READTABLEP COMMONLISP) of RDTBL)
                                      (COND
                                         (NEWVALUEP (replace (READTABLEP COMMONLISP) of RDTBL
                                                       with NEWVALUE)
                                                (if NEWVALUE
                                                    then     (* ; 
                                           "COMMONLISP implies COMMONNUMSYNTAX and not USESILPACKAGE")
                                                         (replace (READTABLEP COMMONNUMSYNTAX)
                                                            of RDTBL with T)
                                                         (replace (READTABLEP USESILPACKAGE)
                                                            of RDTBL with NIL])
                   (COMMONNUMSYNTAX 
                        [PROG1 (fetch (READTABLEP COMMONNUMSYNTAX) of RDTBL)
                               (COND
                                  (NEWVALUEP (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL
                                                with NEWVALUE])
                   (USESILPACKAGE [PROG1 (fetch (READTABLEP USESILPACKAGE) of RDTBL)
                                         (COND
                                            (NEWVALUEP (replace (READTABLEP USESILPACKAGE)
                                                          of RDTBL with NEWVALUE])
                   (CASEINSENSITIVE 
                        [PROG1 (fetch (READTABLEP CASEINSENSITIVE) of RDTBL)
                               (COND
                                  (NEWVALUEP (replace (READTABLEP CASEINSENSITIVE) of RDTBL
                                                with NEWVALUE])
                   (ESCAPECHAR [PROG1 (fetch (READTABLEP ESCAPECHAR) of RDTBL)
                                      (COND
                                         (NEWVALUEP (\SETREADSYNTAX NEWVALUE 'ESCAPE RDTBL)
                                                (replace (READTABLEP ESCAPECHAR) of RDTBL
                                                   with NEWVALUE])
                   (MULTIPLE-ESCAPECHAR 
                        [PROG1 (fetch (READTABLEP MULTESCAPECHAR) of RDTBL)
                               (COND
                                  (NEWVALUEP (\SETREADSYNTAX NEWVALUE 'MULTIPLE-ESCAPE RDTBL)
                                         (replace (READTABLEP MULTESCAPECHAR) of RDTBL with NEWVALUE])
                   (PACKAGECHAR [PROG1 (fetch (READTABLEP PACKAGECHAR) of RDTBL)
                                       (COND
                                          (NEWVALUEP (\SETREADSYNTAX NEWVALUE 'PACKAGEDELIM RDTBL)
                                                 (replace (READTABLEP PACKAGECHAR) of RDTBL
                                                    with NEWVALUE])
                   (HASHMACROCHAR [PROG1 (fetch (READTABLEP HASHMACROCHAR) of RDTBL)
                                         (COND
                                            (NEWVALUEP (\SETREADSYNTAX NEWVALUE
                                                              '(INFIX ALWAYS NONIMMEDIATE ESCQUOTE 
                                                                      READVBAR) RDTBL)
                                                   (replace (READTABLEP HASHMACROCHAR) of RDTBL
                                                      with NEWVALUE])
                   (\ILLEGAL.ARG (ARG ARGS 2])

(RESETREADTABLE
  [LAMBDA (RDTBL FROM)                                 (* ; "Edited 12-Feb-2021 22:54 by larry")
                                                             (* ; 
                                                           "Edited 20-Apr-2018 16:22 by rmk:")
                                                             (* bvm%: "27-Aug-86 22:28")

    (* ;; "RMK: Copy the macrodefs")

    [replace READMACROFLG of (SETQ RDTBL (\GTREADTABLE RDTBL))
       with (fetch READMACROFLG of (SETQ FROM (\GTREADTABLE FROM T]
    (replace ESCAPEFLG of RDTBL with (fetch ESCAPEFLG of FROM))
    (replace (READTABLEP COMMONLISP) of RDTBL with (fetch (READTABLEP 
                                                                                     COMMONLISP)
                                                                      of FROM))
    (replace (READTABLEP NUMBERBASE) of RDTBL with (fetch (READTABLEP 
                                                                                     NUMBERBASE)
                                                                      of FROM))
    (replace (READTABLEP CASEINSENSITIVE) of RDTBL with (fetch (READTABLEP
                                                                                    CASEINSENSITIVE)
                                                                           of FROM))
    (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL with (fetch (READTABLEP
                                                                                    COMMONNUMSYNTAX)
                                                                           of FROM))
    (replace (READTABLEP USESILPACKAGE) of RDTBL with (fetch (READTABLEP
                                                                                  USESILPACKAGE)
                                                                         of FROM))
    (replace (READTABLEP HASHMACROCHAR) of RDTBL with (fetch (READTABLEP
                                                                                  HASHMACROCHAR)
                                                                         of FROM))
    (replace (READTABLEP ESCAPECHAR) of RDTBL with (fetch (READTABLEP 
                                                                                     ESCAPECHAR)
                                                                      of FROM))
    (replace (READTABLEP MULTESCAPECHAR) of RDTBL with (fetch (READTABLEP
                                                                                   MULTESCAPECHAR)
                                                                          of FROM))
    (replace (READTABLEP PACKAGECHAR) of RDTBL with (fetch (READTABLEP 
                                                                                      PACKAGECHAR)
                                                                       of FROM))
    (replace (READTABLEP DISPATCHMACRODEFS) of RDTBL with (COPY (fetch
                                                                                 (READTABLEP
                                                                                  DISPATCHMACRODEFS)
                                                                                   of FROM)))

    (* ;; "Placeholder.  If DISPATCHMACRODEFS ends up containing a CHARTABLE or a hash table, will have to do a REHASH or \COPYSYNTAX as well")

    [LET ((RDEFS (fetch (READTABLEP READMACRODEFS) of RDTBL))
          (FDEFS (fetch (READTABLEP READMACRODEFS) of FROM)))
         (COND
            (RDEFS (CLRHASH RDEFS)))
         (AND FDEFS (REHASH FDEFS (OR RDEFS (replace (READTABLEP READMACRODEFS) of RDTBL
                                               with (HASHARRAY (HARRAYSIZE FDEFS)
                                                               7]
    (\COPYSYNTAX (fetch READSA of FROM)
           (fetch READSA of RDTBL))
    RDTBL])

(SETBRK
  [LAMBDA (LST FLG RDTBL)                                    (* rmk%: "13-AUG-81 00:01")
                                                             (* ; 
             "This is a very ugly def which needs to be cleaned up cause a lot of people call SETBRK")
    (COND
       [(EQ LST T)
        [MAPC (GETSYNTAX 'BREAK RDTBL)
              (FUNCTION (LAMBDA (X)
                          (SETSYNTAX X 'OTHER RDTBL]
        (MAPC (GETSYNTAX 'BREAK (COND
                                   ((EQ RDTBL T)
                                    'ORIG)
                                   (T T)))
              (FUNCTION (LAMBDA (X)
                          (SETSYNTAX X 'BREAK RDTBL]
       (T (SELECTQ FLG
              (NIL                                           (* ; "reset")
                   [MAPC (GETSYNTAX 'BREAK RDTBL)
                         (FUNCTION (LAMBDA (X)
                                     (OR (MEMB X LST)
                                         (SETSYNTAX X 'OTHER RDTBL]
                   [MAPC LST (FUNCTION (LAMBDA (X)
                                         (SETSYNTAX X 'BREAK RDTBL])
              (0                                             (* ; "clear out lst")
                 [MAPC LST (FUNCTION (LAMBDA (X)
                                       (SETSYNTAX X 'OTHER RDTBL])
              (1                                             (* ; "add chars")
                 [MAPC LST (FUNCTION (LAMBDA (X)
                                       (SETSYNTAX X 'BREAK RDTBL])
              NIL])

(SETREADTABLE
  [LAMBDA (RDTBL FLG)                                        (* bvm%: " 4-May-86 16:32")
    (PROG1 *READTABLE* (SETQ *READTABLE* (\GTREADTABLE RDTBL])

(SETSEPR
  [LAMBDA (LST FLG RDTBL)                                    (* rmk%: " 8-JUN-80 07:16")
                                                             (* ; 
                                                             "This one also needs to be cleaned up")
    (COND
       [(EQ LST T)
        [MAPC (GETSYNTAX 'SEPR RDTBL)
              (FUNCTION (LAMBDA (X)
                          (SETSYNTAX X 'OTHER RDTBL]
        (MAPC (GETSYNTAX 'SEPR (COND
                                  ((EQ RDTBL T)
                                   'ORIG)
                                  (T T)))
              (FUNCTION (LAMBDA (X)
                          (SETSYNTAX X 'SEPR RDTBL]
       (T (SELECTQ FLG
              (NIL                                           (* ; "reset")
                   [MAPC (GETSYNTAX 'SEPR RDTBL)
                         (FUNCTION (LAMBDA (X)
                                     (SETSYNTAX X 'OTHER RDTBL]
                   [MAPC LST (FUNCTION (LAMBDA (X)
                                         (SETSYNTAX X 'SEPR RDTBL])
              (0                                             (* ; "clear out lst")
                 [MAPC LST (FUNCTION (LAMBDA (X)
                                       (SETSYNTAX X 'OTHER RDTBL])
              (1                                             (* ; "add chars")
                 [MAPC LST (FUNCTION (LAMBDA (X)
                                       (SETSYNTAX X 'SEPR RDTBL])
              NIL])

(\GETREADSYNTAX
  [LAMBDA (C TBL)                                            (* bvm%: "30-Jun-86 17:49")
    (LET ((B (\SYNCODE (fetch READSA of TBL)
                    C)))
          
          (* ;; "This will turn into a SELECTQ that keys off syntax code numbers and produces class tokens.  The default clause at the end: if it's not a built-in class, must be a macro")
          
          (* ;; "Sample code:")
                                                             (* (SELECTQ B (0 (QUOTE OTHER))
                                                             (140Q (QUOTE SEPRCHAR))
                                                             (160Q (QUOTE BREAKCHAR))
                                                             (161Q (QUOTE STRINGDELIM))
                                                             (162Q (QUOTE LEFTPAREN))
                                                             (163Q (QUOTE RIGHTPAREN))
                                                             (164Q (QUOTE LEFTBRACKET))
                                                             (165Q (QUOTE RIGHTBRACKET))
                                                             (106Q (QUOTE ESCAPE))
                                                             (107Q (QUOTE MULTIPLE-ESCAPE))
                                                             (105Q (QUOTE PACKAGEDELIM)) <default>))
         (\COMPUTED.FORM `(SELECTQ B
                              (\,@ [for PAIR in READCLASSTOKENS
                                      collect (LIST (EVAL (CADR PAIR))
                                                    (KWOTE (CAR PAIR])
                              (LET ((E (\GETREADMACRODEF C TBL))
                                    KEY)
                                   `(,(fetch MACROTYPE of E)
                                     ,(fetch (CONTEXTS KEY) of (fetch MACROCONTEXT of B))
                                     ,@(AND (NEQ (SETQ KEY (fetch (WAKEUPS KEY)
                                                              of (fetch WAKEUP of B)))
                                                 'NONIMMEDIATE)
                                            (LIST KEY))
                                     ,@(AND (NEQ (SETQ KEY (fetch (ESCAPES KEY)
                                                              of (fetch ESCAPE of B)))
                                                 'ESCQUOTE)
                                            (LIST KEY))
                                     ,(fetch MACROFN of E])

(\GTREADTABLE
  [LAMBDA (X FLG)                                            (* bvm%: " 5-May-86 11:05")
    (SELECTQ X
        ((NIL T) 
             (\DTEST *READTABLE* 'READTABLEP))
        (\GTREADTABLE1 X FLG])

(\GTREADTABLE1
  [LAMBDA (X FLG)                                            (* bvm%: "27-Jul-86 15:37")
    (COND
       ((type? READTABLEP X)
        X)
       ((AND FLG (GETHASH X \READTABLEHASH)))
       (T (LISPERROR "ILLEGAL READTABLE" X])

(\ORIGREADTABLE
  [LAMBDA NIL                                                (* ; "Edited 16-Apr-87 17:45 by bvm:")
          
          (* ;; "Creates a copy of the 'original' read-table.")

    (PROG [(TBL (create READTABLEP
                       READMACROFLG _ T
                       ESCAPEFLG _ T
                       NUMBERBASE _ 12Q
                       USESILPACKAGE _ T
                       ESCAPECHAR _ (CHARCODE %%)
                       PACKAGECHAR _ (PROGN 
          
          (* ;; "Need to have a character for package delimiter in all read tables, but for old read tables want one that is unlikely to have appeared in a symbol in an old source file.  Also would like it to be a 7-bit char, so we don't needlessly force MAKEFILE to produce binary files.")

                                            (CHARCODE "^^"))
                       HASHMACROCHAR _ (CHARCODE "|"]
          
          (* ;; "Actually, '|' is not defined in ORIG table, but rather later.  But the radix printer and others want it, and this is better than nothing")

          (SETSEPR (CHARCODE (SPACE TENEXEOL CR ^L LF TAB))
                 1 TBL)
          (\SETREADSYNTAX (CHARCODE %])
                 'RIGHTBRACKET TBL)
          (\SETREADSYNTAX (CHARCODE %[)
                 'LEFTBRACKET TBL)
          (\SETREADSYNTAX (CHARCODE %))
                 'RIGHTPAREN TBL)
          (\SETREADSYNTAX (CHARCODE %()
                 'LEFTPAREN TBL)
          (\SETREADSYNTAX (CHARCODE %%)
                 'ESCAPE TBL)
          (\SETREADSYNTAX (CHARCODE %")
                 'STRINGDELIM TBL)
          (\SETREADSYNTAX 247Q 'PACKAGEDELIM TBL)            (* ; "Old choice for package delim char: the NS section symbol.  Keep for compatibility with Lyric Beta files")
          (\SETREADSYNTAX (CHARCODE "^^")
                 'PACKAGEDELIM TBL)
          (RETURN TBL])

(\READCLASSTOCODE
  [LAMBDA (CLASS)                                            (* bvm%: " 9-Jul-85 00:43")

(* ;;; "This turns into a SELECTQ that goes from CLASS token to numeric code")

    (\COMPUTED.FORM `(SELECTQ CLASS
                         (\,@ READCLASSTOKENS)
                         (SEPR                               (* ; "Synonym for SEPRCHAR")
                               SEPRCHAR.RC)
                         NIL])

(\SETMACROSYNTAX
  [LAMBDA (C CLASS TBL)                                      (* rmk%: " 3-Jan-84 13:20")
    (OR (AND (FMEMB (CAR CLASS)
                    '(MACRO SPLICE INFIX))
             (CDR CLASS))
        (\ILLEGAL.ARG CLASS))
    (PROG (CONTEXT WAKEUP ESCAPE (LST CLASS)
                 (A (fetch READMACRODEFS of TBL)))
      LP  (COND
             ([CDR (SETQ LST (LISTP (CDR LST]
              (OR [AND (NULL CONTEXT)
                       (SETQ CONTEXT (fetch (CONTEXTS VAL) of (CAR LST]
                  [AND (NULL WAKEUP)
                       (SETQ WAKEUP (fetch (WAKEUPS VAL) of (CAR LST]
                  [AND (NULL ESCAPE)
                       (SETQ ESCAPE (fetch (ESCAPES VAL) of (CAR LST]
                  (\ILLEGAL.ARG CLASS))
              (GO LP)))
          (OR (LISTP LST)
              (\ILLEGAL.ARG CLASS))
          [COND
             (A 
          
          (* ;; "This hack guarantees that the hasharray will not overflow and cause an error in the uninterruptable PUTHASH below.  If it didn't already have a value for C, then the macro bits are not set in C's syntax code, so the T value is harmless.")

                (OR (GETHASH C A)
                    (PUTHASH C T A)))
             (T (replace READMACRODEFS of TBL with (SETQ A (HASHARRAY 7 7]
          (UNINTERRUPTABLY
              (PUTHASH C (create READMACRODEF
                                MACROTYPE _ (CAR CLASS)
                                MACROFN _ (CAR LST))
                     A)
              (\SETSYNCODE (fetch READSA of TBL)
                     C
                     (LOGOR (OR CONTEXT ALWAYS.RMC)
                            (OR ESCAPE ESC.RME)
                            (OR WAKEUP NONIMMEDIATE.RMW))))])

(\SETREADSYNTAX
  [LAMBDA (C CLASS TBL)                                      (* bvm%: " 8-Mar-86 16:37")
    (PROG ((OLDSYNTAX (\SYNCODE (fetch (READTABLEP READSA) of TBL)
                             C))
           TEM)
          [COND
             ((EQ CLASS 'BREAK)
              (COND
                 ((fetch BREAK of OLDSYNTAX)
                  (RETURN))
                 (T (SETQ CLASS 'BREAKCHAR]                  (* ; 
                    "If already a BREAK character but also something else, like LPAR, leave it alone")
          (COND
             ((LISTP CLASS)
              (\SETMACROSYNTAX C CLASS TBL))
             ((SETQ TEM (\READCLASSTOCODE CLASS))
              (UNINTERRUPTABLY
                  [COND
                     ((fetch MACROP of OLDSYNTAX)            (* ; "No longer a macro")
                      (REMHASH C (fetch READMACRODEFS of TBL]
                  (\SETSYNCODE (fetch READSA of TBL)
                         C TEM)))
             (T (\ILLEGAL.ARG CLASS])

(\READTABLEP.DEFPRINT
  [LAMBDA (RDTBL STREAM)                                     (* bvm%: "13-Oct-86 17:32")
          
          (* ;; "Print read table as, for example, #<ReadTable name/76,5432>")

    (LET ((NAME (fetch (READTABLEP READTBLNAME) of RDTBL)))
         [.SPACECHECK. STREAM (IPLUS (CONSTANT (NCHARS "<ReadTable />"))
                                     (PROGN                  (* ; "Longest address is `177,177777'")
                                            12Q)
                                     (COND
                                        (NAME (NCHARS NAME))
                                        (T 0]
         (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
         (\SOUT "<ReadTable" STREAM)
         (COND
            (NAME (\OUTCHAR STREAM (CHARCODE SPACE))
                  (\SOUT (MKSTRING NAME)
                         STREAM)))
         (\OUTCHAR STREAM (CHARCODE /))
         (\PRINTADDR RDTBL STREAM)
         (\OUTCHAR STREAM (CHARCODE >))
         T])
)

(PUTPROPS READTABLEPROP ARGNAMES (RDTBL PROP NEWVALUE))
(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ READCLASSTOKENS
       ((OTHER 0)
        (SEPRCHAR (LOGOR ESCAPEBIT STOPATOMBIT 0))
        (BREAKCHAR (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))
        (STRINGDELIM (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))
        (LEFTPAREN (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))
        (RIGHTPAREN (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))
        (LEFTBRACKET (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))
        (RIGHTBRACKET (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))
        (ESCAPE (LOGOR ESCAPEBIT INNERESCAPEBIT 6))
        (MULTIPLE-ESCAPE (LOGOR ESCAPEBIT INNERESCAPEBIT 7))
        (PACKAGEDELIM (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))

(RPAQ READCLASSES [MAPCAR READCLASSTOKENS (FUNCTION (LAMBDA (PAIR)
                                                               (LIST (PACK* (CAR PAIR)
                                                                            ".RC")
                                                                     (CADR PAIR])

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \COMPUTED.FORM MACRO [X (CONS 'PROGN (MAPCAR X (FUNCTION EVAL])
)

(DECLARE%: EVAL@COMPILE

(ACCESSFNS CONTEXTS ((KEY (SELECTC DATUM
                                  (ALWAYS.RMC 'ALWAYS)
                                  (FIRST.RMC 'FIRST)
                                  (ALONE.RMC 'ALONE)
                                  NIL))
                         (VAL (SELECTQ DATUM
                                  (ALWAYS ALWAYS.RMC)
                                  (FIRST FIRST.RMC)
                                  (ALONE ALONE.RMC)
                                  NIL))))

(ACCESSFNS ESCAPES ((KEY (SELECTC DATUM
                                 (ESC.RME 'ESCQUOTE)
                                 (NOESC.RME 'NOESCQUOTE)
                                 NIL))
                        (VAL (SELECTQ DATUM
                                 ((ESCQUOTE ESC) 
                                      ESC.RME)
                                 ((NOESCQUOTE NOESC) 
                                      NOESC.RME)
                                 NIL))))

(ACCESSFNS WAKEUPS ((KEY (SELECTC DATUM
                                 (IMMEDIATE.RMW 'IMMEDIATE)
                                 (NONIMMEDIATE.RMW 
                                      'NONIMMEDIATE)
                                 NIL))
                        (VAL (SELECTQ DATUM
                                 ((IMMEDIATE IMMED WAKEUP) 
                                      IMMEDIATE.RMW)
                                 ((NONIMMEDIATE NONIMMED NOWAKEUP) 
                                      NONIMMEDIATE.RMW)
                                 NIL))))
)

(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS \GETREADMACRODEF MACRO ((C TBL)
                                          (GETHASH C (fetch READMACRODEFS of TBL))))

(PUTPROPS \GTREADTABLE MACRO [ARGS (COND
                                              [(LITATOM (CAR ARGS))
                                               (SUBPAIR '(X . FLG)
                                                      ARGS
                                                      '(SELECTQ X
                                                           ((NIL T) 
                                                                (\DTEST *READTABLE* 'READTABLEP))
                                                           (\GTREADTABLE1 X . FLG]
                                              (T 'IGNOREMACRO])

(PUTPROPS \GTREADTABLE1 DMACRO [ARGS (COND
                                                [(NULL (CDR ARGS))
                                                 (LIST '\DTEST (CAR ARGS)
                                                       ''READTABLEP]
                                                (T 'IGNOREMACRO])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ MACROBIT 10Q)

(RPAQQ BREAKBIT 20Q)

(RPAQQ STOPATOMBIT 40Q)

(RPAQQ ESCAPEBIT 100Q)

(RPAQQ INNERESCAPEBIT 4)


(CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT)
)

(RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
                          (WAKEUPMASK (LOGOR MACROBIT 2))))
(DECLARE%: EVAL@COMPILE 

(RPAQ CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))

(RPAQ WAKEUPMASK (LOGOR MACROBIT 2))


(CONSTANTS (CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1))
       (WAKEUPMASK (LOGOR MACROBIT 2)))
)

(RPAQQ READMACROCONTEXTS ((ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
                              (FIRST.RMC (LOGOR MACROBIT 0))
                              (ALONE.RMC (LOGOR MACROBIT 1))))
(DECLARE%: EVAL@COMPILE 

(RPAQ ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))

(RPAQ FIRST.RMC (LOGOR MACROBIT 0))

(RPAQ ALONE.RMC (LOGOR MACROBIT 1))


(CONSTANTS (ALWAYS.RMC (LOGOR MACROBIT STOPATOMBIT BREAKBIT 0))
       (FIRST.RMC (LOGOR MACROBIT 0))
       (ALONE.RMC (LOGOR MACROBIT 1)))
)

(RPAQQ READCLASSES
       ((OTHER.RC 0)
        (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0))
        (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))
        (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))
        (LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))
        (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))
        (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))
        (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))
        (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6))
        (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7))
        (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))))
(DECLARE%: EVAL@COMPILE 

(RPAQQ OTHER.RC 0)

(RPAQ SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0))

(RPAQ BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))

(RPAQ STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))

(RPAQ LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))

(RPAQ RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))

(RPAQ LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))

(RPAQ RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))

(RPAQ ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6))

(RPAQ MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7))

(RPAQ PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1))


(CONSTANTS (OTHER.RC 0)
       (SEPRCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT 0))
       (BREAKCHAR.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0))
       (STRINGDELIM.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1))
       (LEFTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2))
       (RIGHTPAREN.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3))
       (LEFTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4))
       (RIGHTBRACKET.RC (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5))
       (ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 6))
       (MULTIPLE-ESCAPE.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 7))
       (PACKAGEDELIM.RC (LOGOR ESCAPEBIT INNERESCAPEBIT 1)))
)

(RPAQQ READMACROWAKEUPS ((IMMEDIATE.RMW (LOGOR MACROBIT 2))
                             (NONIMMEDIATE.RMW (LOGOR MACROBIT 0))))
(DECLARE%: EVAL@COMPILE 

(RPAQ IMMEDIATE.RMW (LOGOR MACROBIT 2))

(RPAQ NONIMMEDIATE.RMW (LOGOR MACROBIT 0))


(CONSTANTS (IMMEDIATE.RMW (LOGOR MACROBIT 2))
       (NONIMMEDIATE.RMW (LOGOR MACROBIT 0)))
)

(RPAQQ READMACROESCAPES ((ESC.RME ESCAPEBIT)
                             (NOESC.RME 0)))
(DECLARE%: EVAL@COMPILE 

(RPAQ ESC.RME ESCAPEBIT)

(RPAQQ NOESC.RME 0)


(CONSTANTS (ESC.RME ESCAPEBIT)
       (NOESC.RME 0))
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS READCODE ((ESCAPE (LOGAND DATUM ESCAPEBIT))
                         (ESCQUOTE (BITTEST DATUM ESCAPEBIT))
                         (STOPATOM (BITTEST DATUM STOPATOMBIT))
                         (INNERESCQUOTE (BITTEST DATUM (LOGOR STOPATOMBIT INNERESCAPEBIT)))
                         (MACROCONTEXT (LOGAND DATUM CONTEXTMASK))
                         (MACROP (BITTEST DATUM MACROBIT))
                         (WAKEUP (LOGAND DATUM WAKEUPMASK))
                         (BREAK (BITTEST DATUM BREAKBIT))))

(RECORD READMACRODEF (MACROTYPE . MACROFN))

(DATATYPE READTABLEP ((READSA POINTER)                   (* ; 
                                                         "A CHARTABLE defining syntax of each char")
                          (READMACRODEFS POINTER)            (* ; 
                                      "A hash table associating macro chars with macro definitions")
                          (READMACROFLG FLAG)                (* ; 
           "True if read macros are enabled (turned off by Interlisp's crufty READMACROS function)")
                          (ESCAPEFLG FLAG)                   (* ; "True if the char(s) with escape syntax are enabled (turned off by Interlisp's crufty ESCAPE function)")
                          (COMMONLISP FLAG)                  (* ; 
           "True if table is a Common Lisp read table and hence must obey Common Lisp syntax rules")
                          (NUMBERBASE BITS 5)                (* ; "Not used")
                          (CASEINSENSITIVE FLAG)             (* ; 
                         "If true, unescaped lowercase chars are converted to uppercase in symbols")
                          (COMMONNUMSYNTAX FLAG)             (* ; "True if number notation includes Common Lisp numbers: rationals as a/b, and the dfls exponent markers")
                          (USESILPACKAGE FLAG)               (* ; 
                                   "If true, IL:READ ignores *PACKAGE* and reads in the IL package")
                          (NIL 5 FLAG)
                          (DISPATCHMACRODEFS POINTER)        (* ; 
                                 "An a-list of dispatching macro char and its dispatch definitions")
                          (HASHMACROCHAR BYTE)               (* ; 
                              "The character code used in this read table for the # dispatch macro")
                          (ESCAPECHAR BYTE)                  (* ; 
                                     "The character code used in this read table for single escape")
                          (MULTESCAPECHAR BYTE)              (* ; 
                                   "The character code used in this read table for multiple escape")
                          (PACKAGECHAR BYTE)                 (* ; 
                                 "The character code used in this read table for package delimiter")
                          (READTBLNAME POINTER)              (* ; 
                                                          "The canonical 'name' of this read table")
                          )
                         READSA _ (create CHARTABLE))
)

(/DECLAREDATATYPE 'READTABLEP
       '(POINTER POINTER FLAG FLAG FLAG (BITS 5)
               FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)
       '((READTABLEP 0 POINTER)
         (READTABLEP 2 POINTER)
         (READTABLEP 2 (FLAGBITS . 0))
         (READTABLEP 2 (FLAGBITS . 20Q))
         (READTABLEP 2 (FLAGBITS . 40Q))
         (READTABLEP 4 (BITS . 4))
         (READTABLEP 2 (FLAGBITS . 60Q))
         (READTABLEP 0 (FLAGBITS . 0))
         (READTABLEP 0 (FLAGBITS . 20Q))
         (READTABLEP 0 (FLAGBITS . 40Q))
         (READTABLEP 0 (FLAGBITS . 60Q))
         (READTABLEP 4 (FLAGBITS . 120Q))
         (READTABLEP 4 (FLAGBITS . 140Q))
         (READTABLEP 4 (FLAGBITS . 160Q))
         (READTABLEP 6 POINTER)
         (READTABLEP 5 (BITS . 7))
         (READTABLEP 5 (BITS . 207Q))
         (READTABLEP 4 (BITS . 207Q))
         (READTABLEP 10Q (BITS . 7))
         (READTABLEP 12Q POINTER))
       '14Q)

(* "END EXPORTED DEFINITIONS")


(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE)
)
)

(/DECLAREDATATYPE 'READTABLEP
       '(POINTER POINTER FLAG FLAG FLAG (BITS 5)
               FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER)
       '((READTABLEP 0 POINTER)
         (READTABLEP 2 POINTER)
         (READTABLEP 2 (FLAGBITS . 0))
         (READTABLEP 2 (FLAGBITS . 20Q))
         (READTABLEP 2 (FLAGBITS . 40Q))
         (READTABLEP 4 (BITS . 4))
         (READTABLEP 2 (FLAGBITS . 60Q))
         (READTABLEP 0 (FLAGBITS . 0))
         (READTABLEP 0 (FLAGBITS . 20Q))
         (READTABLEP 0 (FLAGBITS . 40Q))
         (READTABLEP 0 (FLAGBITS . 60Q))
         (READTABLEP 4 (FLAGBITS . 120Q))
         (READTABLEP 4 (FLAGBITS . 140Q))
         (READTABLEP 4 (FLAGBITS . 160Q))
         (READTABLEP 6 POINTER)
         (READTABLEP 5 (BITS . 7))
         (READTABLEP 5 (BITS . 207Q))
         (READTABLEP 4 (BITS . 207Q))
         (READTABLEP 10Q (BITS . 7))
         (READTABLEP 12Q POINTER))
       '14Q)

(RPAQ? \READTABLEHASH )
(DEFINEQ

(\ATBLSET
  [LAMBDA NIL                                           (* ; "Edited 20-Apr-2018 17:34 by rmk:")
                                                             (* ; "Edited  3-Dec-86 18:07 by Pavel")
    (DECLARE (GLOBALVARS \ORIGREADTABLE \ORIGTERMTABLE))
    (COND
       ((NULL (BOUNDP '\PRIMREADTABLE))
        (initrecord CHARTABLE)

        (* ;; "Read tables")

        (* ;; "RMK:  If reloading, don't smash an existing hash table")

        [OR (HARRAYP \READTABLEHASH)
            (SETQ \READTABLEHASH (HASHARRAY 24Q NIL (FUNCTION STRING-EQUAL-HASHBITS)
                                        (FUNCTION STRING-EQUAL]
        (LET (TRDTBL NEW-IL-RDTBL)
             (PROGN                                          (* ; "The ORIG read table")
                    (SETQ \ORIGREADTABLE (\ORIGREADTABLE))
                    (READTABLEPROP \ORIGREADTABLE 'NAME 'ORIG))
             (PROGN                                          (* ; 
                            "The old Interlisp T read table.  May not have a use for this any more")
                    (SETQ TRDTBL (COPYREADTABLE \ORIGREADTABLE))
                    (SETSYNTAX (CHARCODE "|")
                           '(MACRO READVBAR)
                           TRDTBL)
                    (SETSYNTAX (CHARCODE "`")
                           '(MACRO FIRST READBQUOTE)
                           TRDTBL)
                    (SETSYNTAX (CHARCODE ",")
                           '(MACRO FIRST READBQUOTECOMMA)
                           TRDTBL)
                    (SETSYNTAX (CHARCODE "'")
                           '(MACRO FIRST READQUOTE)
                           TRDTBL)
                    (READTABLEPROP TRDTBL 'NAME "OLD-INTERLISP-T")
                    (PROGN                                   (* ; "Temporary")
                           (SETTOPVAL '%#CURRENTRDTBL# TRDTBL)))
             (PROGN                                          (* ; "The old FILERDTBL")
                    (SETQ FILERDTBL (COPYREADTABLE \ORIGREADTABLE))
                    (SETSYNTAX (CHARCODE "|")
                           TRDTBL FILERDTBL)
                    (READTABLEPROP FILERDTBL 'NAME "OLD-INTERLISP-FILE")
                    (SETQ *OLD-INTERLISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT
                                                                  REREADTABLE _ FILERDTBL
                                                                  REBASE _ 12Q))
                                                             (* ; 
                                                           "need this to read files in the loadup")
                    )
             (PROGN (SETQ NEW-IL-RDTBL (COPYREADTABLE TRDTBL))
                                                             (* ; 
                                                "The new Interlisp read table is more common lispy")
                    (READTABLEPROP NEW-IL-RDTBL 'MULTIPLE-ESCAPECHAR (CHARCODE "|"))
                    (READTABLEPROP NEW-IL-RDTBL 'HASHMACROCHAR (CHARCODE "#"))
                    (SET-DEFAULT-HASHMACRO-SETTINGS NEW-IL-RDTBL)
                    (READTABLEPROP NEW-IL-RDTBL 'COMMONNUMSYNTAX T)
                    (READTABLEPROP NEW-IL-RDTBL 'USESILPACKAGE NIL)
                    (READTABLEPROP NEW-IL-RDTBL 'NAME "INTERLISP")
                    (for I from 1 to 32Q do (SETSYNTAX I 'SEPRCHAR FILERDTBL) 
                                                             (* ; "Make font switch chars seprs")
                                                           (SETSYNTAX I 'SEPRCHAR NEW-IL-RDTBL))
                    (SETQ *READTABLE* NEW-IL-RDTBL))

             (* ;; "Make ^Y like #. in the old T readtable and the new INTERLISP one.")

             (SETSYNTAX (CHARCODE ^Y)
                    '[MACRO ALWAYS (LAMBDA (FILE RDTBL)
                                     (EVAL (READ FILE RDTBL]
                    TRDTBL)
             (SETSYNTAX (CHARCODE ^Y)
                    TRDTBL NEW-IL-RDTBL)
             (DEFPRINT 'READTABLEP '\READTABLEP.DEFPRINT))

        (* ;; "Terminal tables")

        (SETQ \ORIGTERMTABLE (\ORIGTERMTABLE))
        (SETQ \PRIMTERMTABLE (COPYTERMTABLE \ORIGTERMTABLE))
        (SETQ \PRIMTERMSA (fetch TERMSA of \PRIMTERMTABLE))
        (PUTD '\ATBLSET)
        (PUTD '\ORIGTERMTABLE)
        NIL])
)

(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER)
       '((READER-ENVIRONMENT 0 POINTER)
         (READER-ENVIRONMENT 2 POINTER)
         (READER-ENVIRONMENT 4 POINTER)
         (READER-ENVIRONMENT 6 POINTER))
       '10Q)



(* ; "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*")

(DEFINEQ

(MAKE-READER-ENVIRONMENT
  [LAMBDA (PACKAGE READTABLE BASE)                           (* ; "Edited 18-Dec-86 18:28 by bvm:")
    (create READER-ENVIRONMENT
           REPACKAGE _ (COND
                          (PACKAGE (\DTEST PACKAGE 'PACKAGE))
                          (T *PACKAGE*))
           REREADTABLE _ (COND
                            (READTABLE (\DTEST READTABLE 'READTABLEP))
                            (T *READTABLE*))
           REBASE _ (COND
                       (BASE (\CHECKRADIX BASE))
                       (T *PRINT-BASE*])

(EQUAL-READER-ENVIRONMENT
  [LAMBDA (ENV1 ENV2)                                        (* bvm%: "31-Jul-86 12:54")
    (AND (EQ (fetch (READER-ENVIRONMENT REREADTABLE) of ENV1)
             (fetch (READER-ENVIRONMENT REREADTABLE) of ENV2))
         (EQ (fetch (READER-ENVIRONMENT REPACKAGE) of ENV1)
             (fetch (READER-ENVIRONMENT REPACKAGE) of ENV2))
         (EQ (fetch (READER-ENVIRONMENT REBASE) of ENV1)
             (fetch (READER-ENVIRONMENT REBASE) of ENV2])

(SET-READER-ENVIRONMENT
  [LAMBDA (ENV)                                              (* bvm%: "28-Aug-86 17:44")

(* ;;; "Sets the reader environment variables from ENV.  Should usually only be called inside a WITH-READER-ENVIRONMENT.")

    [SETQ *PACKAGE* (ffetch REPACKAGE of (\DTEST ENV 'READER-ENVIRONMENT]
    (SETQ *READTABLE* (ffetch REREADTABLE of ENV))
    (SETQ *READ-BASE* (SETQ *PRINT-BASE* (ffetch REBASE of ENV)))
    ENV])
)

(RPAQ? *LISP-PACKAGE* )

(RPAQ? *INTERLISP-PACKAGE* )

(RPAQ? *KEYWORD-PACKAGE* )
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\ATBLSET)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA READTABLEPROP)
)
(PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3706Q 3711Q 
3742Q 3745Q))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (44114Q 67345Q (GETSYNTAX 44126Q . 55055Q) (SETSYNTAX 55057Q . 57144Q) (SYNTAXP 57146Q
 . 62552Q) (\COPYSYNTAX 62554Q . 63637Q) (\GETCHARCODE 63641Q . 64305Q) (\SETFATSYNCODE 64307Q . 
66462Q) (\MAPCHARTABLE 66464Q . 67343Q)) (67406Q 124174Q (CONTROL 67420Q . 70020Q) (COPYTERMTABLE 
70022Q . 70464Q) (DELETECONTROL 70466Q . 75306Q) (GETDELETECONTROL 75310Q . 77216Q) (ECHOCHAR 77220Q
 . 102116Q) (ECHOCONTROL 102120Q . 103040Q) (ECHOMODE 103042Q . 103434Q) (GETECHOMODE 103436Q . 
103706Q) (GETCONTROL 103710Q . 104162Q) (GETTERMTABLE 104164Q . 104267Q) (RAISE 104271Q . 105113Q) (
GETRAISE 105115Q . 105363Q) (RESETTERMTABLE 105365Q . 107465Q) (SETTERMTABLE 107467Q . 110156Q) (
TERMTABLEP 110160Q . 110425Q) (\GETTERMSYNTAX 110427Q . 111036Q) (\GTTERMTABLE 111040Q . 111564Q) (
\ORIGTERMTABLE 111566Q . 120427Q) (\SETTERMSYNTAX 120431Q . 121630Q) (\TERMCLASSTOCODE 121632Q . 
122513Q) (\TERMCODETOCLASS 122515Q . 123324Q) (\LITCHECK 123326Q . 124172Q)) (131165Q 210145Q (
COPYREADTABLE 131177Q . 131511Q) (FIND-READTABLE 131513Q . 131742Q) (IN-READTABLE 131744Q . 132210Q) (
ESCAPE 132212Q . 132613Q) (GETBRK 132615Q . 133033Q) (GETREADTABLE 133035Q . 133246Q) (GETSEPR 133250Q
 . 133466Q) (READMACROS 133470Q . 134103Q) (READTABLEP 134105Q . 134354Q) (READTABLEPROP 134356Q . 
146554Q) (RESETREADTABLE 146556Q . 157076Q) (SETBRK 157100Q . 162204Q) (SETREADTABLE 162206Q . 162473Q
) (SETSEPR 162475Q . 165475Q) (\GETREADSYNTAX 165477Q . 172657Q) (\GTREADTABLE 172661Q . 173226Q) (
\GTREADTABLE1 173230Q . 173634Q) (\ORIGREADTABLE 173636Q . 177455Q) (\READCLASSTOCODE 177457Q . 
200366Q) (\SETMACROSYNTAX 200370Q . 204004Q) (\SETREADSYNTAX 204006Q . 206071Q) (\READTABLEP.DEFPRINT 
206073Q . 210143Q)) (241661Q 252517Q (\ATBLSET 241673Q . 252515Q)) (253256Q 256351Q (
MAKE-READER-ENVIRONMENT 253270Q . 254356Q) (EQUAL-READER-ENVIRONMENT 254360Q . 255407Q) (
SET-READER-ENVIRONMENT 255411Q . 256347Q)))))
STOP
\ No newline at end of file
diff --git a/sources/ATBL.LCOM b/sources/ATBL.LCOM
index e3c6e859..5281c39e 100644
Binary files a/sources/ATBL.LCOM and b/sources/ATBL.LCOM differ
diff --git a/sources/DLFIXINIT b/sources/DLFIXINIT
index c10cbe6e..6ec6fa4d 100644
--- a/sources/DLFIXINIT
+++ b/sources/DLFIXINIT
@@ -1,44 +1,4 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "29-Jan-98 17:51:06" {DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>DLFIXINIT.;2 27711  
-
-      changes to%:  (FNS DLCOPYPAGEMAP)
-
-      previous date%: " 9-Nov-92 14:54:57" 
-{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>DLFIXINIT.;1)
-
-
-(* ; "
-Copyright (c) 1983, 1984, 1990, 1992, 1998 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT DLFIXINITCOMS)
-
-(RPAQQ DLFIXINITCOMS 
-       [(FNS DLFIXINIT DLSORTSYSOUTPAGES DLNEXTFP DLLOCKEDPAGEP DLSETLOCKBIT DLCOPYPAGEMAP 
-             DLCOPYVMPAGE DLADDPAGEMAPENTRIES ASSIGNFILEPAGE ASSIGNFILEPAGERANGE DLDUMPSYSOUT 
-             DLDUMPFPTOVP DLDUMPPAGEMAPS DLDUMPVMEMPAGES DLSETBOOTPTR DLDUMPARRAY DLMARKASDUMPED 
-             DLDUMPVMEMPAGE INSTALLDOMINO INSTALLDOMINO.DIRECT INSTALLNEWDOMINO)
-        (FNS DLPRINTFPTOVP PRINTPRIMARYMAP DLREADPAGEOFWORDS SETDIF)
-        (CONSTANTS \NO.PAGE.ASSIGNED)
-        (GLOBALVARS DLPRIMARYMAP DLSECONDARYMAP DLLOCKBITS DLLASTDOMINOPAGE DLIFPAGE DLNEXTPM 
-               DLPAGEMAPFP FPTOVP NEWFPFROMOLD VMEMFILE VMEMFILEX)
-        (DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
-                                                              READSYS LLFAULT)
-               (P (CHECKIMPORTS '(MODARITH LLPARAMS)
-                         T])
-(DEFINEQ
-
-(DLFIXINIT
  [LAMBDA (SYSOUTFILE DLBOOTFILE DBFILE %#UCODEPAGES)
                                                  (* ; 
                                                "Edited  2-Nov-92 08:16 by sybalsky:mv:envos")
    [COND
       ((NOT DLBOOTFILE)
        (SETQ DLBOOTFILE (PACKFILENAME 'EXTENSION 'DLINIT 'VERSION NIL 'BODY SYSOUTFILE]
    (FILESLOAD (SYSLOAD)
           READSYS RDSYS)
    (RESETLST
        (SETQ DBFILE (OPENFILE (OR DBFILE '{PHYLUM}<LISPCORE>FUGUE>DLISPDOMINO.DB)
                            'INPUT))
        (RESETSAVE NIL (LIST 'CLOSEF DBFILE))
        (PROG ((DBPAGES (IPLUS (FOLDHI (GETFILEINFO DBFILE 'LENGTH)
                                      BYTESPERPAGE)
                               2))
               (%#ADDEDFILEPAGES 0)
               %#OLDFILEPAGES %#NEWFILEPAGES %#FPTOVPPAGES DLFILEX)
              (DECLARE (SPECVARS %#NEWFILEPAGES %#OLDFILEPAGES %#ADDEDFILEPAGES %#FPTOVPPAGES 
                                  DLFILEX))                  (* ; 
                                         "Plus 2 is to allow for interface page and copy of page 0")
              (COND
                 ((NOT %#UCODEPAGES)
                  (SETQ %#UCODEPAGES (IQUOTIENT (ITIMES DBPAGES 5)
                                            4))
                  (printout T "  Assuming " .P2 %#UCODEPAGES " pages of uCode/Domino" T))
                 ((ILESSP %#UCODEPAGES DBPAGES)
                  (printout T "Not enough space for Domino; raising it to " .P2 (SETQ %#UCODEPAGES 
                                                                                 DBPAGES)
                         " pages" T)))
              (READSYS SYSOUTFILE)
              (RESETSAVE NIL '(READSYS))                     (* ; 
                                                           "To close the sysout source on exit")
              (SETQ %#OLDFILEPAGES (FOLDHI (GETFILEINFO VMEMFILE 'LENGTH)
                                          BYTESPERPAGE))
              (DLCOPYPAGEMAP)
              (SETQ NEWFPFROMOLD (ARRAY %#OLDFILEPAGES 'WORD \NO.PAGE.ASSIGNED 1))
              (DLSORTSYSOUTPAGES)
              (until (ERSETQ (DLDUMPSYSOUT)) do (printout T T 
                                                                  "DLFIXINIT failed, trying again..."
                                                                   T))
              (RETURN DLBOOTFILE)))])
-
-(DLSORTSYSOUTPAGES
  [LAMBDA NIL                                 (* ; 
                                                "Edited  4-Nov-92 15:47 by sybalsky:mv:envos")
    (DECLARE (USEDFREE FPSIZE NEWFPFROMOLD FPTOVPSIZE FPTOVP PGTAB %#FPTOVPPAGES)
           (SPECVARS LASTFP))
    (PROG (LASTFP)
          (ASSIGNFILEPAGE \FP.IFPAGE \VP.IFPAGE (SUB1 \FP.IFPAGE)
                 T)                                          (* ; 
                                        "SUB1 because old FP's are zero-based! See VMEM structures")
          (ASSIGNFILEPAGERANGE \VP.DISPLAY \NP.DISPLAY (DLFPFROMRP \RP.TEMPDISPLAY))
          (ASSIGNFILEPAGERANGE \VP.STACK PAGESPERSEGMENT (DLFPFROMRP \RP.STACK)
                 T)
          (ASSIGNFILEPAGERANGE \VP.TYPETABLE \NP.TYPETABLE (DLFPFROMRP \RP.TYPETABLE))
          (ASSIGNFILEPAGERANGE \VP.GCTABLE \NP.GCTABLE (DLFPFROMRP \RP.GCTABLE))
          (ASSIGNFILEPAGERANGE \VP.GCOVERFLOW \NP.GCOVERFLOW (DLFPFROMRP \RP.GCOVERFLOW))
          (ASSIGNFILEPAGERANGE \VP.FPTOVP %#FPTOVPPAGES (DLFPFROMRP \RP.FPTOVP))
          (replace (IFPAGE FPTOVPStart) of DLIFPAGE with (DLFPFROMRP \RP.FPTOVP))
          (replace (IFPAGE LastDominoFilePage) of DLIFPAGE with (SETQ DLLASTDOMINOPAGE 
                                                                             %#UCODEPAGES))
          [SETQ LASTFP (SUB1 (SETQ DLPAGEMAPFP (DLFPFROMRP \RP.MISCLOCKED]

     (* ;; "Assign next the pagemap pages, since we have to know where they live (some are new) and it is very convenient for them to be contiguous")

          (for J from 0 to (SUB1 \NumPMTpages) do (ASSIGNFILEPAGE (DLNEXTFP)
                                                                         (IPLUS J \VP.PRIMARYMAP)
                                                                         NIL T))
          (replace (IFPAGE filePnPMT0) of DLIFPAGE with DLPAGEMAPFP)
          (replace (IFPAGE filePnPMP0) of DLIFPAGE with (IPLUS DLPAGEMAPFP \NumPMTpages))

     (* ;; "NO LONGER -- 5,,0 TAKEN FOR FPTOVP IN MEDLEY 2.1 -- but we need the decondary page table up thru building things, so assign it:")

          (for J from 0 to (SUB1 (FOLDHI DLNEXTPM WORDSPERPAGE))
             do (ASSIGNFILEPAGE (DLNEXTFP)
                           (IPLUS J \VP.SECONDARYMAP)
                           NIL T))

     (* ;; "Similarly, assign locked page table, which is another structure we rewrite")

          (for J from 0 to (SUB1 \NumLPTPages) do (ASSIGNFILEPAGE (DLNEXTFP)
                                                                         (IPLUS J \VP.LPT)
                                                                         NIL T))

     (* ;; "Finally, assign file pages for everyone we haven't taken care of yet.  First the locked pages, which have to be at the front of the sysout, after the fixed assignments we have already made")

          [for IFLOCKED in '(T NIL)
             do (for VPSEG from 0 to \MAXVMSEGMENT bind PGTAB2
                       when (NEQ (SETQ PGTAB2 (FASTELT PGTAB VPSEG))
                                     PGEMPTY)
                       do (for I from 0 to (SUB1 PAGESPERSEGMENT)
                                 bind (VPBASE _ (UNFOLD VPSEG PAGESPERSEGMENT))
                                       OLDFP when (AND [NOT (ZEROP (SETQ OLDFP (FASTELTN PGTAB2 I
                                                                                          ]
                                                           (EQ (DLLOCKEDPAGEP (IPLUS VPBASE I))
                                                               IFLOCKED)
                                                           (EQ (FASTELTN NEWFPFROMOLD OLDFP)
                                                               \NO.PAGE.ASSIGNED))
                                 do (ASSIGNFILEPAGE (DLNEXTFP)
                                               (IPLUS VPBASE I)
                                               OLDFP IFLOCKED)))
                   (COND
                      (IFLOCKED (replace (IFPAGE LastLockedFilePage) of DLIFPAGE with
                                                                                         LASTFP)
                             (SETQ LASTFP DLLASTDOMINOPAGE]
          (replace (IFPAGE NDirtyPages) of DLIFPAGE with (replace (IFPAGE 
                                                                                         NActivePages
                                                                                         )
                                                                        of DLIFPAGE with
                                                                                        
                                                                                       %#NEWFILEPAGES
                                                                            ])
-
-(DLNEXTFP
  [LAMBDA NIL                                 (* ; 
                                                "Edited  2-Nov-92 12:29 by sybalsky:mv:envos")
    (do (add LASTFP 1) repeatuntil (EQ (FASTELTN FPTOVP (LLSH LASTFP 1))
                                                   \NO.VMEM.PAGE))
    LASTFP])
-
-(DLLOCKEDPAGEP
  [LAMBDA (VP)                                           (* bvm%: " 6-Dec-84 22:25")
    (NEQ 0 (LOGAND (.LOCKEDVPMASK. VP)
                  (FASTELTN DLLOCKBITS (FOLDLO VP BITSPERWORD])
-
-(DLSETLOCKBIT
  [LAMBDA (VP)                                           (* bvm%: " 6-Dec-84 22:26")
    (FASTSETAN DLLOCKBITS (FOLDLO VP BITSPERWORD)
           (LOGOR (.LOCKEDVPMASK. VP)
                  (FASTELTN DLLOCKBITS (FOLDLO VP BITSPERWORD])
-
-(DLCOPYPAGEMAP
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 7-Feb-2021 21:08:57" {DSK}<home>larry>ilisp>medley>sources>DLFIXINIT.;6 26465  

      changes to%:  (FNS DLDUMPSYSOUT)

      previous date%: " 7-Feb-2021 14:45:27" {DSK}<home>larry>ilisp>medley>sources>DLFIXINIT.;5)


(PRETTYCOMPRINT DLFIXINITCOMS)

(RPAQQ DLFIXINITCOMS
       [
        (* ;; " This file is all because the dandelion needed its microcode embedded in the init file, and MAIKO wasn't around. So this is all to make room for microcode we don't need. Except something(?) might expect the %"InterfacePage%" as page 2 of the file, so we're leaving it in place now")

        (FNS DLFIXINIT DLSORTSYSOUTPAGES DLNEXTFP DLLOCKEDPAGEP DLSETLOCKBIT DLCOPYPAGEMAP 
             DLCOPYVMPAGE DLADDPAGEMAPENTRIES ASSIGNFILEPAGE ASSIGNFILEPAGERANGE DLDUMPSYSOUT 
             DLDUMPFPTOVP DLDUMPPAGEMAPS DLDUMPVMEMPAGES DLSETBOOTPTR DLDUMPARRAY DLMARKASDUMPED 
             DLDUMPVMEMPAGE INSTALLDOMINO INSTALLDOMINO.DIRECT INSTALLNEWDOMINO)
        (FILES RDSYS READSYS)
        (FNS DLPRINTFPTOVP PRINTPRIMARYMAP DLREADPAGEOFWORDS SETDIF)
        (CONSTANTS \NO.PAGE.ASSIGNED)
        (GLOBALVARS DLPRIMARYMAP DLSECONDARYMAP DLLOCKBITS DLLASTDOMINOPAGE DLIFPAGE DLNEXTPM 
               DLPAGEMAPFP FPTOVP NEWFPFROMOLD VMEMFILE VMEMFILEX)
        (DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                              READSYS LLFAULT)
               (P (CHECKIMPORTS '(MODARITH LLPARAMS)
                         T])



(* ;; 
" This file is all because the dandelion needed its microcode embedded in the init file, and MAIKO wasn't around. So this is all to make room for microcode we don't need. Except something(?) might expect the %"InterfacePage%" as page 2 of the file, so we're leaving it in place now"
)

(DEFINEQ

(DLFIXINIT
  [LAMBDA (SYSOUTFILE DLBOOTFILE)                        (* ; "Edited  7-Feb-2021 13:49 by lmm")
                                                             (* ; 
                                                      "Edited  2-Nov-92 08:16 by sybalsky:mv:envos")
    (PROG ((DBPAGES 3)
           (%#UCODEPAGES 3)
           (%#ADDEDFILEPAGES 0)
           %#OLDFILEPAGES %#NEWFILEPAGES %#FPTOVPPAGES DLFILEX)
          (DECLARE (SPECVARS %#UCODEPAGES NEWFPFROMOLD DBPAGES %#NEWFILEPAGES %#OLDFILEPAGES 
                              %#ADDEDFILEPAGES %#FPTOVPPAGES DLFILEX))
          (READSYS SYSOUTFILE)
          (SETQ %#OLDFILEPAGES (FOLDHI (GETFILEINFO VMEMFILE 'LENGTH)
                                      BYTESPERPAGE))
          (DLCOPYPAGEMAP)
          (SETQ NEWFPFROMOLD (ARRAY %#OLDFILEPAGES 'WORD \NO.PAGE.ASSIGNED 1))
          (DLSORTSYSOUTPAGES)
          (DLDUMPSYSOUT)
          (READSYS)
          (RETURN DLBOOTFILE])

(DLSORTSYSOUTPAGES
  [LAMBDA NIL                                 (* ; 
                                                "Edited  4-Nov-92 15:47 by sybalsky:mv:envos")
    (DECLARE (USEDFREE FPSIZE NEWFPFROMOLD FPTOVPSIZE FPTOVP PGTAB %#FPTOVPPAGES)
           (SPECVARS LASTFP))
    (PROG (LASTFP)
          (ASSIGNFILEPAGE \FP.IFPAGE \VP.IFPAGE (SUB1 \FP.IFPAGE)
                 T)                                          (* ; 
                                        "SUB1 because old FP's are zero-based! See VMEM structures")
          (ASSIGNFILEPAGERANGE \VP.DISPLAY \NP.DISPLAY (DLFPFROMRP \RP.TEMPDISPLAY))
          (ASSIGNFILEPAGERANGE \VP.STACK PAGESPERSEGMENT (DLFPFROMRP \RP.STACK)
                 T)
          (ASSIGNFILEPAGERANGE \VP.TYPETABLE \NP.TYPETABLE (DLFPFROMRP \RP.TYPETABLE))
          (ASSIGNFILEPAGERANGE \VP.GCTABLE \NP.GCTABLE (DLFPFROMRP \RP.GCTABLE))
          (ASSIGNFILEPAGERANGE \VP.GCOVERFLOW \NP.GCOVERFLOW (DLFPFROMRP \RP.GCOVERFLOW))
          (ASSIGNFILEPAGERANGE \VP.FPTOVP %#FPTOVPPAGES (DLFPFROMRP \RP.FPTOVP))
          (replace (IFPAGE FPTOVPStart) of DLIFPAGE with (DLFPFROMRP \RP.FPTOVP))
          (replace (IFPAGE LastDominoFilePage) of DLIFPAGE with (SETQ DLLASTDOMINOPAGE 
                                                                             %#UCODEPAGES))
          [SETQ LASTFP (SUB1 (SETQ DLPAGEMAPFP (DLFPFROMRP \RP.MISCLOCKED]

     (* ;; "Assign next the pagemap pages, since we have to know where they live (some are new) and it is very convenient for them to be contiguous")

          (for J from 0 to (SUB1 \NumPMTpages) do (ASSIGNFILEPAGE (DLNEXTFP)
                                                                         (IPLUS J \VP.PRIMARYMAP)
                                                                         NIL T))
          (replace (IFPAGE filePnPMT0) of DLIFPAGE with DLPAGEMAPFP)
          (replace (IFPAGE filePnPMP0) of DLIFPAGE with (IPLUS DLPAGEMAPFP \NumPMTpages))

     (* ;; "NO LONGER -- 5,,0 TAKEN FOR FPTOVP IN MEDLEY 2.1 -- but we need the decondary page table up thru building things, so assign it:")

          (for J from 0 to (SUB1 (FOLDHI DLNEXTPM WORDSPERPAGE))
             do (ASSIGNFILEPAGE (DLNEXTFP)
                           (IPLUS J \VP.SECONDARYMAP)
                           NIL T))

     (* ;; "Similarly, assign locked page table, which is another structure we rewrite")

          (for J from 0 to (SUB1 \NumLPTPages) do (ASSIGNFILEPAGE (DLNEXTFP)
                                                                         (IPLUS J \VP.LPT)
                                                                         NIL T))

     (* ;; "Finally, assign file pages for everyone we haven't taken care of yet.  First the locked pages, which have to be at the front of the sysout, after the fixed assignments we have already made")

          [for IFLOCKED in '(T NIL)
             do (for VPSEG from 0 to \MAXVMSEGMENT bind PGTAB2
                       when (NEQ (SETQ PGTAB2 (FASTELT PGTAB VPSEG))
                                     PGEMPTY)
                       do (for I from 0 to (SUB1 PAGESPERSEGMENT)
                                 bind (VPBASE _ (UNFOLD VPSEG PAGESPERSEGMENT))
                                       OLDFP when (AND [NOT (ZEROP (SETQ OLDFP (FASTELTN PGTAB2 I
                                                                                          ]
                                                           (EQ (DLLOCKEDPAGEP (IPLUS VPBASE I))
                                                               IFLOCKED)
                                                           (EQ (FASTELTN NEWFPFROMOLD OLDFP)
                                                               \NO.PAGE.ASSIGNED))
                                 do (ASSIGNFILEPAGE (DLNEXTFP)
                                               (IPLUS VPBASE I)
                                               OLDFP IFLOCKED)))
                   (COND
                      (IFLOCKED (replace (IFPAGE LastLockedFilePage) of DLIFPAGE with
                                                                                         LASTFP)
                             (SETQ LASTFP DLLASTDOMINOPAGE]
          (replace (IFPAGE NDirtyPages) of DLIFPAGE with (replace (IFPAGE 
                                                                                         NActivePages
                                                                                         )
                                                                        of DLIFPAGE with
                                                                                        
                                                                                       %#NEWFILEPAGES
                                                                            ])

(DLNEXTFP
  [LAMBDA NIL                                 (* ; 
                                                "Edited  2-Nov-92 12:29 by sybalsky:mv:envos")
    (do (add LASTFP 1) repeatuntil (EQ (FASTELTN FPTOVP (LLSH LASTFP 1))
                                                   \NO.VMEM.PAGE))
    LASTFP])

(DLLOCKEDPAGEP
  [LAMBDA (VP)                                           (* bvm%: " 6-Dec-84 22:25")
    (NEQ 0 (LOGAND (.LOCKEDVPMASK. VP)
                  (FASTELTN DLLOCKBITS (FOLDLO VP BITSPERWORD])

(DLSETLOCKBIT
  [LAMBDA (VP)                                           (* bvm%: " 6-Dec-84 22:26")
    (FASTSETAN DLLOCKBITS (FOLDLO VP BITSPERWORD)
           (LOGOR (.LOCKEDVPMASK. VP)
                  (FASTELTN DLLOCKBITS (FOLDLO VP BITSPERWORD])

(DLCOPYPAGEMAP
   [LAMBDA NIL                                 (* ; 
                                                 "Edited  3-Nov-92 15:46 by sybalsky:mv:envos")
     (PROG NIL
@@ -89,78 +49,4 @@ Copyright (c) 1983, 1984, 1990, 1992, 1998 by Venue & Xerox Corporation.  All ri
           (for J from 0 to (SUB1 \NumLPTPages)
              do (DLCOPYVMPAGE (IPLUS J \VP.LPT)
                            (\ADDBASE (fetch (ARRAYP BASE) of DLLOCKBITS)
-                                  (UNFOLD J WORDSPERPAGE])
-
-(DLCOPYVMPAGE
  [LAMBDA (VP BASE)                                      (* bvm%: "14-Dec-84 12:46")
                                                             (* Reads page VP from VMEMFILE into 
                                                           BASE, returning BASE)
    (SETVMPTR (UNFOLD VP WORDSPERPAGE))
    (\BINS VMEMFILEX BASE 0 BYTESPERPAGE)
    BASE])
-
-(DLADDPAGEMAPENTRIES
  [LAMBDA (VP NPAGES)                                    (* bvm%: "27-MAR-83 17:53")
    (to NPAGES do [COND
                             ((IEQ (FASTELTN DLPRIMARYMAP (fetch (VP PRIMARYKEY) of VP))
                                   \EmptyPMTEntry)
                              (COND
                                 ((EVENP DLNEXTPM WORDSPERPAGE)
                                                             (* must add a new page map page)
                                  (add %#ADDEDFILEPAGES 1)))
                              (FASTSETAN DLPRIMARYMAP (fetch (VP PRIMARYKEY) of VP)
                                     DLNEXTPM)
                              (SETQ DLNEXTPM (IPLUS DLNEXTPM \PMblockSize]
                         (add VP 1])
-
-(ASSIGNFILEPAGE
  [LAMBDA (FP VP OLDFP LOCKED)                (* ; 
                                                "Edited  9-Nov-92 14:54 by sybalsky:mv:envos")

    (* ;; "Assign VP to live in FP (and hence a related real page);  OLDFP is where VP lives in the old sysout")

    (COND
       ([NOT (ZEROP (OR OLDFP (SETQ OLDFP (LOGAND (FASTELTN (FASTELT PGTAB (LRSH VP 8))
                                                         (LOGAND VP 255))
                                                 32767]
        (FASTSETAN NEWFPFROMOLD OLDFP FP)))
    (FASTSETAN FPTOVP (ADD1 (LLSH FP 1))
           VP)
    (FASTSETAN FPTOVP (LLSH FP 1)
           0)
    (PROG [(SECONDARY (FASTELTN DLPRIMARYMAP (fetch (VP PRIMARYKEY) of VP]
                                                             (* ; 
                                                           "Update pagemap to point to the new FP")
          (COND
             ((IEQ SECONDARY \EmptyPMTEntry)
              (HELP VP "has no primary map entry"))
             (T (FASTSETAN DLSECONDARYMAP (IPLUS SECONDARY (fetch (VP SECONDARYKEY) of VP))
                       FP)))
          (COND
             (LOCKED (DLSETLOCKBIT VP])
-
-(ASSIGNFILEPAGERANGE
  [LAMBDA (VPSTART NPAGES FPSTART ONLYIFTHERE)           (* bvm%: "25-MAR-83 12:44")
    (for I from 0 to (SUB1 NPAGES) unless [AND ONLYIFTHERE
                                                               (NOT (VMPAGEP (IPLUS VPSTART I]
       do (ASSIGNFILEPAGE (IPLUS FPSTART I)
                     (IPLUS VPSTART I)
                     NIL T])
-
-(DLDUMPSYSOUT
  [LAMBDA NIL                                 (* ; 
                                                "Edited  3-Nov-92 10:50 by sybalsky:mv:envos")
    (PROG [(DLPAGEOFZEROS (NCREATE 'VMEMPAGEP]
          [RESETSAVE [SETQ DLFILEX (OPENSTREAM DLBOOTFILE 'OUTPUT 'NEW 8
                                          (CONS (LIST 'LENGTH (UNFOLD %#NEWFILEPAGES BYTESPERPAGE))
                                                '((SEQUENTIAL T)
                                                  (TYPE BINARY]
                 '(PROGN (CLOSEF? OLDVALUE)
                         (AND RESETSTATE (DELFILE OLDVALUE]
          (SETQ DLBOOTFILE (FULLNAME DLFILEX))
          (PROGN (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE)   (* ; "First page of domino")
                 (\BOUTS DLFILEX DLIFPAGE 0 BYTESPERPAGE)    (* ; "Interface Page")
                 (COPYBYTES DBFILE DLFILEX)                  (* ; "Rest of Domino")
                 (RPTQ (IDIFFERENCE (UNFOLD (SUB1 DLLASTDOMINOPAGE)
                                           BYTESPERPAGE)
                              (IPLUS (GETFILEPTR DBFILE)
                                     BYTESPERPAGE))
                       (\BOUT DLFILEX 0))                    (* ; 
                               "(SETFILEPTR DLFILEX (UNFOLD (SUB1 DLLASTDOMINOPAGE) BYTESPERPAGE))")
                 (SETFILEPTR DBFILE 0)
                 (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE)   (* ; "Replicate domino first page")
                 )
          (DLDUMPVMEMPAGES (ADD1 DLLASTDOMINOPAGE)
                 (SUB1 (DLFPFROMRP \RP.FPTOVP)))
          (DLDUMPFPTOVP)
          (DLDUMPVMEMPAGES (IPLUS (DLFPFROMRP \RP.FPTOVP)
                                      %#FPTOVPPAGES)
                 (SUB1 DLPAGEMAPFP))
          (DLDUMPPAGEMAPS)
          (DLDUMPVMEMPAGES (IPLUS DLPAGEMAPFP \NumPMTpages (FOLDHI DLNEXTPM WORDSPERPAGE)
                                      \NumLPTPages)
                 %#NEWFILEPAGES])
-
-(DLDUMPFPTOVP
  [LAMBDA NIL                                 (* ; 
                                                "Edited  4-Nov-92 13:56 by sybalsky:mv:envos")
    (printout T "[FPTOVP]")

    (* ;; "Filepages are one-based, but FPTOVP in the sysout is zero-based for convenience.  Hence, first entry (page zero) is dummy")

    (\WOUT DLFILEX \NO.VMEM.PAGE)

    (* ;; "With BIG VM, each FPTOVP entry is 2 words, and word 1 (the 1st element of the array) is actually part of the entry for page 0 (which we dumped the other half above).  So we need to dump 2*#pages + 1 elements of the array:")

    (DLDUMPARRAY FPTOVP (ADD1 (LLSH %#NEWFILEPAGES 1)))
    (RPTQ (IDIFFERENCE (UNFOLD %#FPTOVPPAGES WORDSPERPAGE)
                 (LLSH (ADD1 %#NEWFILEPAGES)
                       1))
          (\WOUT DLFILEX \NO.VMEM.PAGE))                     (* ; "Fill out rest of FPTOVP with no such page.  Fill from #pages*2 (it's cells now, not words per FPTOVP entry), out to the end of the FPTOVP pages.")
    NIL])
-
-(DLDUMPPAGEMAPS
  [LAMBDA NIL                                 (* ; 
                                                "Edited  3-Nov-92 10:47 by sybalsky:mv:envos")
    (printout T "[PageMaps]")
    (DLDUMPARRAY DLPRIMARYMAP (UNFOLD \NumPMTpages WORDSPERPAGE))
                                                             (* ; "Dump primary map")
    (DLDUMPARRAY DLSECONDARYMAP (CEIL DLNEXTPM WORDSPERPAGE))
                                                             (* ; "Dump secondary map")
    (DLDUMPARRAY DLLOCKBITS (UNFOLD \NumLPTPages WORDSPERPAGE))
                                                             (* ; "Dump locked page table")
    NIL])
-
-(DLDUMPVMEMPAGES
  [LAMBDA (FIRSTFP LASTFP)                    (* ; 
                                                "Edited  2-Nov-92 12:30 by sybalsky:mv:envos")
    (for FP from FIRSTFP to LASTFP bind VP
       do (COND
                 ((AND (NEQ [SETQ VP (FASTELTN FPTOVP (ADD1 (LLSH FP 1]
                            \NO.VMEM.PAGE)
                       (VMPAGEP VP))
                  (SETVMPTR (UNFOLD VP WORDSPERPAGE))
                  (COPYBYTES VMEMFILE DLFILEX BYTESPERPAGE)
                  (PRIN1 '* T))
                 (T (\BOUTS DLFILEX DLPAGEOFZEROS 0 BYTESPERPAGE)
                    (PRIN1 'x T])
-
-(DLSETBOOTPTR
  [LAMBDA (FP)                                           (* bvm%: "27-MAR-83 17:39")
    (printout T "[" .P2 FP "]")
    (SETFILEPTR DLFILEX (UNFOLD (SUB1 FP)
                               BYTESPERPAGE])
-
-(DLDUMPARRAY
  [LAMBDA (ARR NWORDS)                        (* ; 
                                                "Edited  3-Nov-92 11:52 by sybalsky:mv:envos")

    (* ;; "Dump NWORDS from array ARR, starting with the first byte in the array's contents.")

    (\BOUTS DLFILEX (fetch (ARRAYP BASE) of ARR)
           0
           (UNFOLD NWORDS BYTESPERWORD])
-
-(DLMARKASDUMPED
  [LAMBDA (FIRSTFP NPAGES)                    (* ; 
                                                "Edited  2-Nov-92 12:30 by sybalsky:mv:envos")
    (for I from FIRSTFP to (IPLUS FIRSTFP NPAGES -1) do (FASTSETAN FPTOVP
                                                                               (LLSH I 1)
                                                                               \NO.VMEM.PAGE])
-
-(DLDUMPVMEMPAGE
  [LAMBDA (NEWFP VP LOCKEDP)                             (* bvm%: "28-MAR-83 12:11")
    (COND
       ((VMPAGEP VP)
        (SETVMPTR (UNFOLD VP WORDSPERPAGE))
        [PROG ((DESTINATIONBYTE (UNFOLD (SUB1 NEWFP)
                                       BYTESPERPAGE)))
              (COND
                 ((NOT (IEQP (\GETFILEPTR DLFILEX)
                             DESTINATIONBYTE))
                  (printout T "[" .P2 NEWFP "]")
                  (SETFILEPTR DLFILEX DESTINATIONBYTE]
        (COPYBYTES VMEMFILE DLFILEX BYTESPERPAGE)
        (PRIN1 (COND
                  (LOCKEDP '$)
                  (T '*))
               T))
       (T (PRIN1 'x T])
-
-(INSTALLDOMINO
  [LAMBDA (DBFILE)                                       (* edited%: "14-APR-83 12:00")
    (DLSETBOOTPTR 1)
    (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE)
    (DLSETBOOTPTR (ADD1 \FP.IFPAGE))                     (* Skip over InterfacePage)
    (COPYBYTES DBFILE DLFILEX)                               (* Copy rest of Domino)
    (DLSETBOOTPTR DLLASTDOMINOPAGE)
    (SETFILEPTR DBFILE 0)

         (* Copy first DB page into scratch at end of Domino reserved space so that 
       SYSOUT can get it (Dolphin and Dorado smash first page of vmem))

    (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE])
-
-(INSTALLDOMINO.DIRECT
  [LAMBDA (DBFILE)                                       (* bvm%: "29-JUL-83 16:16")
    (PROG [(BUFFER (COND
                      ((IGREATERP \#SWAPBUFFERS 1)
                       (RESETSAVE \EMUSWAPBUFFERS (\ADDBASE \EMUSWAPBUFFERS WORDSPERPAGE))
                       (RESETSAVE \#SWAPBUFFERS (SUB1 \#SWAPBUFFERS))
                       \EMUSWAPBUFFERS)
                      (T (RESETSAVE \EMUDISKBUFFERS (\ADDBASE \EMUDISKBUFFERS WORDSPERPAGE))
                         (RESETSAVE \#DISKBUFFERS (SUB1 \#DISKBUFFERS))
                         \EMUDISKBUFFERS]
          (replace ENDOFSTREAMOP of DBFILE with (FUNCTION ZERO))
          (\BINS DBFILE BUFFER 0 BYTESPERPAGE)
          (COND
             ((EQ \MACHINETYPE \DANDELION)
              (\ACTONVMEMFILE 1 BUFFER 1 T)))
          (\BINS DBFILE BUFFER 0 BYTESPERPAGE)               (* Skip over InterfacePage)
          (for I from (ADD1 \FP.IFPAGE) until (\EOFP DBFILE)
             do (\BINS DBFILE BUFFER 0 BYTESPERPAGE)
                   (\ACTONVMEMFILE I BUFFER 1 T))            (* Copy rest of Domino)
      ])
-
-(INSTALLNEWDOMINO
  [LAMBDA (SYSOUTFILE DBFILE)                            (* bvm%: "29-JUL-83 16:08")
    (RESETLST
        (SETQ DBFILE (GETSTREAM (OPENFILE (OR DBFILE (INFILEP '{DSK}DLISPDOMINO.DB)
                                              '{PHYLUM}<LISPCORE>DLION>BASICS>DLISPDOMINO.DB)
                                       'INPUT)
                            'INPUT))
        (RESETSAVE NIL (LIST 'CLOSEF DBFILE))
        (PROG ((DBPAGES (IPLUS (FOLDHI (GETFILEINFO DBFILE 'LENGTH)
                                      BYTESPERPAGE)
                               2))
               %#UCODEPAGES DLFILEX)
              (DECLARE (SPECVARS DLFILEX))
              [COND
                 [SYSOUTFILE [RESETSAVE NIL (LIST 'CLOSEF (SETQ SYSOUTFILE (OPENFILE SYSOUTFILE
                                                                                  'INPUT]
                        (SETQ %#UCODEPAGES (SETQ DLLASTDOMINOPAGE (fetch (IFPAGE 
                                                                                   LastDominoFilePage
                                                                                    )
                                                                     of (\MAPPAGE 1 (GETSTREAM
                                                                                         SYSOUTFILE]
                 ((ASKUSER NIL NIL (LIST "Shall I install" (fetch FULLFILENAME of DBFILE)
                                         "directly into the vmem file"))
                  (SETQ %#UCODEPAGES (SETQ DLLASTDOMINOPAGE (fetch (IFPAGE LastDominoFilePage)
                                                               of \InterfacePage]
              (COND
                 ((ILESSP %#UCODEPAGES DBPAGES)
                  (RETURN "Not enough space for Domino")))
              (COND
                 (SYSOUTFILE (OPENFILE (CLOSEF SYSOUTFILE)
                                    'BOTH)
                        (SETQ DLFILEX (GETSTREAM SYSOUTFILE))
                        (INSTALLDOMINO DBFILE))
                 (T (INSTALLDOMINO.DIRECT DBFILE)))
              (RETURN SYSOUTFILE)))])
-)
-(DEFINEQ
-
-(DLPRINTFPTOVP
  [LAMBDA (STREAM)                                       (* bvm%: "28-MAR-83 12:42")
    (\PRINTFPTOVP (\ADDBASE (fetch (ARRAYP BASE) of FPTOVP)
                         -1)
           (fetch (IFPAGE NActivePages) of DLIFPAGE)
           STREAM])
-
-(PRINTPRIMARYMAP
  [LAMBDA NIL                                            (* bvm%: "28-MAR-83 23:25")
    (for I from 0 to 63
       do (printout T I ":  " 8)
             [for J from 0 to 7 bind PMPE
                do (COND
                          ((EQ [SETQ PMPE (ELT DLPRIMARYMAP (PLUS J (TIMES I 8]
                               65535)
                           (printout T " -----"))
                          (T (printout T .I6.8 PMPE]
             (TERPRI T) unless (for J from 0 to 7
                                      always (EQ (ELT DLPRIMARYMAP (PLUS J (TIMES I 8)))
                                                     65535])
-
-(DLREADPAGEOFWORDS
  [LAMBDA (STREAM)                                       (* bvm%: "29-MAR-83 00:03")
    (to WORDSPERPAGE collect (\WIN STREAM])
-
-(SETDIF
  [LAMBDA (X Y)                                          (* bvm%: "28-MAR-83 15:28")
    (for EL in X collect EL unless (FMEMB EL Y])
-)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \NO.PAGE.ASSIGNED 0)
-
-
-(CONSTANTS \NO.PAGE.ASSIGNED)
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS DLPRIMARYMAP DLSECONDARYMAP DLLOCKBITS DLLASTDOMINOPAGE DLIFPAGE DLNEXTPM DLPAGEMAPFP 
-       FPTOVP NEWFPFROMOLD VMEMFILE VMEMFILEX)
-)
-(DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY 
-
-(FILESLOAD (LOADCOMP)
-       READSYS LLFAULT)
-
-
-(CHECKIMPORTS '(MODARITH LLPARAMS)
-       T)
-)
-(PUTPROPS DLFIXINIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1990 1992 1998))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1368 25824 (DLFIXINIT 1378 . 3816) (DLSORTSYSOUTPAGES 3818 . 8944) (DLNEXTFP 8946 . 
-9283) (DLLOCKEDPAGEP 9285 . 9499) (DLSETLOCKBIT 9501 . 9763) (DLCOPYPAGEMAP 9765 . 12816) (
-DLCOPYVMPAGE 12818 . 13208) (DLADDPAGEMAPENTRIES 13210 . 14025) (ASSIGNFILEPAGE 14027 . 15260) (
-ASSIGNFILEPAGERANGE 15262 . 15669) (DLDUMPSYSOUT 15671 . 17682) (DLDUMPFPTOVP 17684 . 18723) (
-DLDUMPPAGEMAPS 18725 . 19425) (DLDUMPVMEMPAGES 19427 . 20083) (DLSETBOOTPTR 20085 . 20315) (
-DLDUMPARRAY 20317 . 20704) (DLMARKASDUMPED 20706 . 21159) (DLDUMPVMEMPAGE 21161 . 21849) (
-INSTALLDOMINO 21851 . 22498) (INSTALLDOMINO.DIRECT 22500 . 23652) (INSTALLNEWDOMINO 23654 . 25822)) (
-25825 27182 (DLPRINTFPTOVP 25835 . 26124) (PRINTPRIMARYMAP 26126 . 26840) (DLREADPAGEOFWORDS 26842 . 
-27009) (SETDIF 27011 . 27180)))))
-STOP
+                                  (UNFOLD J WORDSPERPAGE])

(DLCOPYVMPAGE
  [LAMBDA (VP BASE)                                      (* bvm%: "14-Dec-84 12:46")
                                                             (* Reads page VP from VMEMFILE into 
                                                           BASE, returning BASE)
    (SETVMPTR (UNFOLD VP WORDSPERPAGE))
    (\BINS VMEMFILEX BASE 0 BYTESPERPAGE)
    BASE])

(DLADDPAGEMAPENTRIES
  [LAMBDA (VP NPAGES)                                    (* bvm%: "27-MAR-83 17:53")
    (to NPAGES do [COND
                             ((IEQ (FASTELTN DLPRIMARYMAP (fetch (VP PRIMARYKEY) of VP))
                                   \EmptyPMTEntry)
                              (COND
                                 ((EVENP DLNEXTPM WORDSPERPAGE)
                                                             (* must add a new page map page)
                                  (add %#ADDEDFILEPAGES 1)))
                              (FASTSETAN DLPRIMARYMAP (fetch (VP PRIMARYKEY) of VP)
                                     DLNEXTPM)
                              (SETQ DLNEXTPM (IPLUS DLNEXTPM \PMblockSize]
                         (add VP 1])

(ASSIGNFILEPAGE
  [LAMBDA (FP VP OLDFP LOCKED)                (* ; 
                                                "Edited  9-Nov-92 14:54 by sybalsky:mv:envos")

    (* ;; "Assign VP to live in FP (and hence a related real page);  OLDFP is where VP lives in the old sysout")

    (COND
       ([NOT (ZEROP (OR OLDFP (SETQ OLDFP (LOGAND (FASTELTN (FASTELT PGTAB (LRSH VP 8))
                                                         (LOGAND VP 255))
                                                 32767]
        (FASTSETAN NEWFPFROMOLD OLDFP FP)))
    (FASTSETAN FPTOVP (ADD1 (LLSH FP 1))
           VP)
    (FASTSETAN FPTOVP (LLSH FP 1)
           0)
    (PROG [(SECONDARY (FASTELTN DLPRIMARYMAP (fetch (VP PRIMARYKEY) of VP]
                                                             (* ; 
                                                           "Update pagemap to point to the new FP")
          (COND
             ((IEQ SECONDARY \EmptyPMTEntry)
              (HELP VP "has no primary map entry"))
             (T (FASTSETAN DLSECONDARYMAP (IPLUS SECONDARY (fetch (VP SECONDARYKEY) of VP))
                       FP)))
          (COND
             (LOCKED (DLSETLOCKBIT VP])

(ASSIGNFILEPAGERANGE
  [LAMBDA (VPSTART NPAGES FPSTART ONLYIFTHERE)           (* bvm%: "25-MAR-83 12:44")
    (for I from 0 to (SUB1 NPAGES) unless [AND ONLYIFTHERE
                                                               (NOT (VMPAGEP (IPLUS VPSTART I]
       do (ASSIGNFILEPAGE (IPLUS FPSTART I)
                     (IPLUS VPSTART I)
                     NIL T])

(DLDUMPSYSOUT
  [LAMBDA NIL                                          (* ; "Edited  7-Feb-2021 20:46 by larry")
                                                             (* ; "Edited  7-Feb-2021 14:28 by lmm")
                                                             (* ; 
                                                      "Edited  3-Nov-92 10:50 by sybalsky:mv:envos")
    (PROG [(DLPAGEOFZEROS (NCREATE 'VMEMPAGEP]
          [SETQ DLFILEX (OPENSTREAM DLBOOTFILE 'OUTPUT 'NEW 8 (CONS (LIST 'LENGTH (UNFOLD 
                                                                                       %#NEWFILEPAGES
                                                                                         BYTESPERPAGE
                                                                                         ))
                                                                    '((SEQUENTIAL T)
                                                                      (TYPE BINARY]
          (SETQ DLBOOTFILE (FULLNAME DLFILEX))
          (PROGN (\BOUTS DLFILEX DLPAGEOFZEROS 0 BYTESPERPAGE)
                 (\BOUTS DLFILEX DLIFPAGE 0 BYTESPERPAGE)
                 (\BOUTS DLFILEX DLPAGEOFZEROS 0 BYTESPERPAGE))
          (DLDUMPVMEMPAGES (ADD1 DLLASTDOMINOPAGE)
                 (SUB1 (DLFPFROMRP \RP.FPTOVP)))
          (DLDUMPFPTOVP)
          (DLDUMPVMEMPAGES (IPLUS (DLFPFROMRP \RP.FPTOVP)
                                      %#FPTOVPPAGES)
                 (SUB1 DLPAGEMAPFP))
          (DLDUMPPAGEMAPS)
          (DLDUMPVMEMPAGES (IPLUS DLPAGEMAPFP \NumPMTpages (FOLDHI DLNEXTPM WORDSPERPAGE)
                                      \NumLPTPages)
                 %#NEWFILEPAGES)
          (CLOSEF DLFILEX])

(DLDUMPFPTOVP
  [LAMBDA NIL                                 (* ; 
                                                "Edited  4-Nov-92 13:56 by sybalsky:mv:envos")
    (printout T "[FPTOVP]")

    (* ;; "Filepages are one-based, but FPTOVP in the sysout is zero-based for convenience.  Hence, first entry (page zero) is dummy")

    (\WOUT DLFILEX \NO.VMEM.PAGE)

    (* ;; "With BIG VM, each FPTOVP entry is 2 words, and word 1 (the 1st element of the array) is actually part of the entry for page 0 (which we dumped the other half above).  So we need to dump 2*#pages + 1 elements of the array:")

    (DLDUMPARRAY FPTOVP (ADD1 (LLSH %#NEWFILEPAGES 1)))
    (RPTQ (IDIFFERENCE (UNFOLD %#FPTOVPPAGES WORDSPERPAGE)
                 (LLSH (ADD1 %#NEWFILEPAGES)
                       1))
          (\WOUT DLFILEX \NO.VMEM.PAGE))                     (* ; "Fill out rest of FPTOVP with no such page.  Fill from #pages*2 (it's cells now, not words per FPTOVP entry), out to the end of the FPTOVP pages.")
    NIL])

(DLDUMPPAGEMAPS
  [LAMBDA NIL                                 (* ; 
                                                "Edited  3-Nov-92 10:47 by sybalsky:mv:envos")
    (printout T "[PageMaps]")
    (DLDUMPARRAY DLPRIMARYMAP (UNFOLD \NumPMTpages WORDSPERPAGE))
                                                             (* ; "Dump primary map")
    (DLDUMPARRAY DLSECONDARYMAP (CEIL DLNEXTPM WORDSPERPAGE))
                                                             (* ; "Dump secondary map")
    (DLDUMPARRAY DLLOCKBITS (UNFOLD \NumLPTPages WORDSPERPAGE))
                                                             (* ; "Dump locked page table")
    NIL])

(DLDUMPVMEMPAGES
  [LAMBDA (FIRSTFP LASTFP)                    (* ; 
                                                "Edited  2-Nov-92 12:30 by sybalsky:mv:envos")
    (for FP from FIRSTFP to LASTFP bind VP
       do (COND
                 ((AND (NEQ [SETQ VP (FASTELTN FPTOVP (ADD1 (LLSH FP 1]
                            \NO.VMEM.PAGE)
                       (VMPAGEP VP))
                  (SETVMPTR (UNFOLD VP WORDSPERPAGE))
                  (COPYBYTES VMEMFILE DLFILEX BYTESPERPAGE)
                  (PRIN1 '* T))
                 (T (\BOUTS DLFILEX DLPAGEOFZEROS 0 BYTESPERPAGE)
                    (PRIN1 'x T])

(DLSETBOOTPTR
  [LAMBDA (FP)                                           (* bvm%: "27-MAR-83 17:39")
    (printout T "[" .P2 FP "]")
    (SETFILEPTR DLFILEX (UNFOLD (SUB1 FP)
                               BYTESPERPAGE])

(DLDUMPARRAY
  [LAMBDA (ARR NWORDS)                        (* ; 
                                                "Edited  3-Nov-92 11:52 by sybalsky:mv:envos")

    (* ;; "Dump NWORDS from array ARR, starting with the first byte in the array's contents.")

    (\BOUTS DLFILEX (fetch (ARRAYP BASE) of ARR)
           0
           (UNFOLD NWORDS BYTESPERWORD])

(DLMARKASDUMPED
  [LAMBDA (FIRSTFP NPAGES)                    (* ; 
                                                "Edited  2-Nov-92 12:30 by sybalsky:mv:envos")
    (for I from FIRSTFP to (IPLUS FIRSTFP NPAGES -1) do (FASTSETAN FPTOVP
                                                                               (LLSH I 1)
                                                                               \NO.VMEM.PAGE])

(DLDUMPVMEMPAGE
  [LAMBDA (NEWFP VP LOCKEDP)                             (* bvm%: "28-MAR-83 12:11")
    (COND
       ((VMPAGEP VP)
        (SETVMPTR (UNFOLD VP WORDSPERPAGE))
        [PROG ((DESTINATIONBYTE (UNFOLD (SUB1 NEWFP)
                                       BYTESPERPAGE)))
              (COND
                 ((NOT (IEQP (\GETFILEPTR DLFILEX)
                             DESTINATIONBYTE))
                  (printout T "[" .P2 NEWFP "]")
                  (SETFILEPTR DLFILEX DESTINATIONBYTE]
        (COPYBYTES VMEMFILE DLFILEX BYTESPERPAGE)
        (PRIN1 (COND
                  (LOCKEDP '$)
                  (T '*))
               T))
       (T (PRIN1 'x T])

(INSTALLDOMINO
  [LAMBDA (DBFILE)                                       (* edited%: "14-APR-83 12:00")
    (DLSETBOOTPTR 1)
    (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE)
    (DLSETBOOTPTR (ADD1 \FP.IFPAGE))                     (* Skip over InterfacePage)
    (COPYBYTES DBFILE DLFILEX)                               (* Copy rest of Domino)
    (DLSETBOOTPTR DLLASTDOMINOPAGE)
    (SETFILEPTR DBFILE 0)

         (* Copy first DB page into scratch at end of Domino reserved space so that 
       SYSOUT can get it (Dolphin and Dorado smash first page of vmem))

    (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE])

(INSTALLDOMINO.DIRECT
  [LAMBDA (DBFILE)                                       (* bvm%: "29-JUL-83 16:16")
    (PROG [(BUFFER (COND
                      ((IGREATERP \#SWAPBUFFERS 1)
                       (RESETSAVE \EMUSWAPBUFFERS (\ADDBASE \EMUSWAPBUFFERS WORDSPERPAGE))
                       (RESETSAVE \#SWAPBUFFERS (SUB1 \#SWAPBUFFERS))
                       \EMUSWAPBUFFERS)
                      (T (RESETSAVE \EMUDISKBUFFERS (\ADDBASE \EMUDISKBUFFERS WORDSPERPAGE))
                         (RESETSAVE \#DISKBUFFERS (SUB1 \#DISKBUFFERS))
                         \EMUDISKBUFFERS]
          (replace ENDOFSTREAMOP of DBFILE with (FUNCTION ZERO))
          (\BINS DBFILE BUFFER 0 BYTESPERPAGE)
          (COND
             ((EQ \MACHINETYPE \DANDELION)
              (\ACTONVMEMFILE 1 BUFFER 1 T)))
          (\BINS DBFILE BUFFER 0 BYTESPERPAGE)               (* Skip over InterfacePage)
          (for I from (ADD1 \FP.IFPAGE) until (\EOFP DBFILE)
             do (\BINS DBFILE BUFFER 0 BYTESPERPAGE)
                   (\ACTONVMEMFILE I BUFFER 1 T))            (* Copy rest of Domino)
      ])

(INSTALLNEWDOMINO
  [LAMBDA (SYSOUTFILE DBFILE)                            (* bvm%: "29-JUL-83 16:08")
    (RESETLST
        (SETQ DBFILE (GETSTREAM (OPENFILE (OR DBFILE (INFILEP '{DSK}DLISPDOMINO.DB)
                                              '{PHYLUM}<LISPCORE>DLION>BASICS>DLISPDOMINO.DB)
                                       'INPUT)
                            'INPUT))
        (RESETSAVE NIL (LIST 'CLOSEF DBFILE))
        (PROG ((DBPAGES (IPLUS (FOLDHI (GETFILEINFO DBFILE 'LENGTH)
                                      BYTESPERPAGE)
                               2))
               %#UCODEPAGES DLFILEX)
              (DECLARE (SPECVARS DLFILEX))
              [COND
                 [SYSOUTFILE [RESETSAVE NIL (LIST 'CLOSEF (SETQ SYSOUTFILE (OPENFILE SYSOUTFILE
                                                                                  'INPUT]
                        (SETQ %#UCODEPAGES (SETQ DLLASTDOMINOPAGE (fetch (IFPAGE 
                                                                                   LastDominoFilePage
                                                                                    )
                                                                     of (\MAPPAGE 1 (GETSTREAM
                                                                                         SYSOUTFILE]
                 ((ASKUSER NIL NIL (LIST "Shall I install" (fetch FULLFILENAME of DBFILE)
                                         "directly into the vmem file"))
                  (SETQ %#UCODEPAGES (SETQ DLLASTDOMINOPAGE (fetch (IFPAGE LastDominoFilePage)
                                                               of \InterfacePage]
              (COND
                 ((ILESSP %#UCODEPAGES DBPAGES)
                  (RETURN "Not enough space for Domino")))
              (COND
                 (SYSOUTFILE (OPENFILE (CLOSEF SYSOUTFILE)
                                    'BOTH)
                        (SETQ DLFILEX (GETSTREAM SYSOUTFILE))
                        (INSTALLDOMINO DBFILE))
                 (T (INSTALLDOMINO.DIRECT DBFILE)))
              (RETURN SYSOUTFILE)))])
)

(FILESLOAD RDSYS READSYS)
(DEFINEQ

(DLPRINTFPTOVP
  [LAMBDA (STREAM)                                       (* bvm%: "28-MAR-83 12:42")
    (\PRINTFPTOVP (\ADDBASE (fetch (ARRAYP BASE) of FPTOVP)
                         -1)
           (fetch (IFPAGE NActivePages) of DLIFPAGE)
           STREAM])

(PRINTPRIMARYMAP
  [LAMBDA NIL                                            (* bvm%: "28-MAR-83 23:25")
    (for I from 0 to 63
       do (printout T I ":  " 8)
             [for J from 0 to 7 bind PMPE
                do (COND
                          ((EQ [SETQ PMPE (ELT DLPRIMARYMAP (PLUS J (TIMES I 8]
                               65535)
                           (printout T " -----"))
                          (T (printout T .I6.8 PMPE]
             (TERPRI T) unless (for J from 0 to 7
                                      always (EQ (ELT DLPRIMARYMAP (PLUS J (TIMES I 8)))
                                                     65535])

(DLREADPAGEOFWORDS
  [LAMBDA (STREAM)                                       (* bvm%: "29-MAR-83 00:03")
    (to WORDSPERPAGE collect (\WIN STREAM])

(SETDIF
  [LAMBDA (X Y)                                          (* bvm%: "28-MAR-83 15:28")
    (for EL in X collect EL unless (FMEMB EL Y])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \NO.PAGE.ASSIGNED 0)


(CONSTANTS \NO.PAGE.ASSIGNED)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DLPRIMARYMAP DLSECONDARYMAP DLLOCKBITS DLLASTDOMINOPAGE DLIFPAGE DLNEXTPM DLPAGEMAPFP 
       FPTOVP NEWFPFROMOLD VMEMFILE VMEMFILEX)
)
(DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY 

(FILESLOAD (LOADCOMP)
       READSYS LLFAULT)


(CHECKIMPORTS '(MODARITH LLPARAMS)
       T)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1881 24637 (DLFIXINIT 1891 . 2879) (DLSORTSYSOUTPAGES 2881 . 8007) (DLNEXTFP 8009 . 
8346) (DLLOCKEDPAGEP 8348 . 8562) (DLSETLOCKBIT 8564 . 8826) (DLCOPYPAGEMAP 8828 . 11879) (
DLCOPYVMPAGE 11881 . 12271) (DLADDPAGEMAPENTRIES 12273 . 13088) (ASSIGNFILEPAGE 13090 . 14323) (
ASSIGNFILEPAGERANGE 14325 . 14732) (DLDUMPSYSOUT 14734 . 16495) (DLDUMPFPTOVP 16497 . 17536) (
DLDUMPPAGEMAPS 17538 . 18238) (DLDUMPVMEMPAGES 18240 . 18896) (DLSETBOOTPTR 18898 . 19128) (
DLDUMPARRAY 19130 . 19517) (DLMARKASDUMPED 19519 . 19972) (DLDUMPVMEMPAGE 19974 . 20662) (
INSTALLDOMINO 20664 . 21311) (INSTALLDOMINO.DIRECT 21313 . 22465) (INSTALLNEWDOMINO 22467 . 24635)) (
24665 26022 (DLPRINTFPTOVP 24675 . 24964) (PRINTPRIMARYMAP 24966 . 25680) (DLREADPAGEOFWORDS 25682 . 
25849) (SETDIF 25851 . 26020)))))
STOP
\ No newline at end of file
diff --git a/sources/DLFIXINIT.LCOM b/sources/DLFIXINIT.LCOM
index cefd8ac0..a8f36d86 100644
Binary files a/sources/DLFIXINIT.LCOM and b/sources/DLFIXINIT.LCOM differ
diff --git a/sources/FASLOAD.DFASL b/sources/FASLOAD.DFASL
deleted file mode 100644
index c36b503d..00000000
Binary files a/sources/FASLOAD.DFASL and /dev/null differ
diff --git a/sources/FASLOAD.LCOM b/sources/FASLOAD.LCOM
new file mode 100755
index 00000000..3d95e81a
Binary files /dev/null and b/sources/FASLOAD.LCOM differ
diff --git a/sources/FILEPKG b/sources/FILEPKG
index cafb9363..6b6cfaee 100644
--- a/sources/FILEPKG
+++ b/sources/FILEPKG
@@ -1 +1 @@
-(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
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "12-Feb-2021 17:16:04" {DSK}<home>larry>ilisp>medley>sources>FILEPKG.;16 282953 

      changes to%:  (VARS FILEPKGCOMS)
                    (FNS ADDTOFILEKEYLST)

      previous date%: "27-Oct-2020 15:40:32" {DSK}<home>larry>ilisp>medley>sources>FILEPKG.;15)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995, 2018, 2020, 
2021 by Venue & Xerox Corporation.
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")

              (FNS ADDTOFILEKEYLST)
              (INITVARS (ADDTOFILEKEYLST (ADDTOFILEKEYLST))
                     (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"
)

(DEFINEQ

(ADDTOFILEKEYLST
  [LAMBDA NIL                                          (* ; "Edited 12-Feb-2021 17:15 by larry")
    `(("[" "" 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 (])
)

(RPAQ? ADDTOFILEKEYLST (ADDTOFILEKEYLST))

(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  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 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (20677 22382 (SEARCHPRETTYTYPELST 20687 . 21666) (PRETTYDEFMACROS 21668 . 22126) (
FILEPKGCOMPROPS 22128 . 22380)) (23184 57307 (CLEANUP 23194 . 24582) (COMPILEFILES 24584 . 24860) (
COMPILEFILES0 24862 . 25582) (CONTINUEDIT 25584 . 27004) (MAKEFILE 27006 . 38648) (FILECHANGES 38650
 . 40985) (FILEPKG.MERGECHANGES 40987 . 41810) (FILEPKG.CHANGEDFNS 41812 . 42124) (MAKEFILE1 42126 . 
46353) (COMPILE-FILE? 46355 . 47912) (MAKEFILES 47914 . 49607) (ADDFILE 49609 . 52130) (ADDFILE0 52132
 . 56268) (LISTFILES 56270 . 57305)) (57995 93235 (FILEPKGCHANGES 58005 . 59355) (GETFILEPKGTYPE 59357
 . 62430) (MARKASCHANGED 62432 . 64069) (FILECOMS 64071 . 64455) (WHEREIS 64457 . 65877) (
SMASHFILECOMS 65879 . 66114) (FILEFNSLST 66116 . 66278) (FILECOMSLST 66280 . 66764) (UPDATEFILES 66766
 . 72066) (INFILECOMS? 72068 . 73971) (INFILECOMTAIL 73973 . 75113) (INFILECOMS 75115 . 75276) (
INFILECOM 75278 . 85487) (INFILECOMSVALS 85489 . 85816) (INFILECOMSVAL 85818 . 86820) (INFILECOMSPROP 
86822 . 87651) (IFCPROPS 87653 . 88914) (IFCEXPRTYPE 88916 . 89427) (IFCPROPSCAN 89429 . 90482) (
IFCDECLARE 90484 . 91795) (INFILEPAIRS 91797 . 92129) (INFILECOMSMACRO 92131 . 93233)) (93270 124046 (
FILES? 93280 . 95473) (FILES?1 95475 . 96125) (FILES?PRINTLST 96127 . 96909) (ADDTOFILES? 96911 . 
107513) (ADDTOFILE 107515 . 108431) (WHATIS 108433 . 110409) (ADDTOCOMS 110411 . 112055) (ADDTOCOM 
112057 . 118604) (ADDTOCOM1 118606 . 119777) (ADDNEWCOM 119779 . 120829) (MAKENEWCOM 120831 . 122674) 
(DEFAULTMAKENEWCOM 122676 . 124044)) (124116 126933 (MERGEINSERT 124126 . 126469) (MERGEINSERT1 126471
 . 126931)) (127087 128444 (ADDTOFILEKEYLST 127097 . 128442)) (128561 139473 (DELFROMFILES 128571 . 
129421) (DELFROMCOMS 129423 . 131102) (DELFROMCOM 131104 . 136972) (DELFROMCOM1 136974 . 137771) (
REMOVEITEM 137773 . 138647) (MOVETOFILE 138649 . 139471)) (139687 142056 (SAVEPUT 139697 . 142054)) (
142181 150505 (UNMARKASCHANGED 142191 . 143899) (PREEDITFN 143901 . 146412) (POSTEDITPROPS 146414 . 
148915) (POSTEDITALISTS 148917 . 150503)) (150654 171208 (ALISTS.GETDEF 150664 . 151043) (
ALISTS.WHENCHANGED 151045 . 151689) (CLEARCLISPARRAY 151691 . 152865) (EXPRESSIONS.WHENCHANGED 152867
 . 153241) (MAKEALISTCOMS 153243 . 154316) (MAKEFILESCOMS 154318 . 155755) (MAKELISPXMACROSCOMS 155757
 . 157775) (MAKEPROPSCOMS 157777 . 158475) (MAKEUSERMACROSCOMS 158477 . 160277) (PROPS.WHENCHANGED 
160279 . 160900) (FILEGETDEF.LISPXMACROS 160902 . 162344) (FILEGETDEF.ALISTS 162346 . 162965) (
FILEGETDEF.RECORDS 162967 . 163898) (FILEGETDEF.PROPS 163900 . 164692) (FILEGETDEF.MACROS 164694 . 
165754) (FILEGETDEF.VARS 165756 . 166172) (FILEGETDEF.FNS 166174 . 167538) (FILEPKGCOMS.PUTDEF 167540
 . 169980) (FILES.PUTDEF 169982 . 170939) (VARS.PUTDEF 170941 . 171084) (FILES.WHENCHANGED 171086 . 
171206)) (173230 180663 (RENAME 173240 . 174641) (CHANGECALLERS 174643 . 180661)) (180664 228612 (
SHOWDEF 180674 . 181467) (COPYDEF 181469 . 183943) (GETDEF 183945 . 186221) (GETDEFCOM 186223 . 187189
) (GETDEFCOM0 187191 . 188537) (GETDEFCURRENT 188539 . 194959) (GETDEFERR 194961 . 196262) (
GETDEFFROMFILE 196264 . 200544) (GETDEFSAVED 200546 . 201650) (PUTDEF 201652 . 202355) (EDITDEF 202357
 . 203334) (DEFAULT.EDITDEF 203336 . 206172) (EDITDEF.FILES 206174 . 206375) (LOADDEF 206377 . 206553)
 (DWIMDEF 206555 . 207409) (DELDEF 207411 . 210425) (DELFROMLIST 210427 . 210931) (HASDEF 210933 . 
217255) (GETFILEDEF 217257 . 217779) (SAVEDEF 217781 . 219440) (UNSAVEDEF 219442 . 220338) (
COMPAREDEFS 220340 . 223642) (COMPARE 223644 . 224348) (TYPESOF 224350 . 228610)) (228679 233722 (
FIXEDITDATE 228689 . 232192) (EDITDATE? 232194 . 233720)) (234141 242727 (FILEPKGCOM 234151 . 239084) 
(FILEPKGTYPE 239086 . 242725)) (254764 269316 (FINDCALLERS 254774 . 255289) (EDITCALLERS 255291 . 
262949) (EDITFROMFILE 262951 . 268631) (FINDATS 268633 . 268905) (LOOKIN 268907 . 269314)) (269317 
271044 (SEPRCASE 269327 . 271042)) (271561 277103 (IMPORTFILE 271571 . 272545) (IMPORTEVAL 272547 . 
273427) (IMPORTFILESCAN 273429 . 273850) (CHECKIMPORTS 273852 . 275188) (GATHEREXPORTS 275190 . 276513
) (\DUMPEXPORTS 276515 . 277101)) (277441 279649 (CLEARFILEPKG 277451 . 279647)))))
STOP
\ No newline at end of file
diff --git a/sources/FILEPKG.LCOM b/sources/FILEPKG.LCOM
index c3d5a0d8..9d08805a 100644
Binary files a/sources/FILEPKG.LCOM and b/sources/FILEPKG.LCOM differ
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/FILESETS b/sources/FILESETS
index 44f2109e..dcb746e2 100644
--- a/sources/FILESETS
+++ b/sources/FILESETS
@@ -1,175 +1 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "29-Jan-98 16:26:53" {DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>FILESETS.;2 7340   
-
-      changes to%:  (VARS RENAMETYPES)
-
-      previous date%: " 9-Apr-90 16:57:44" 
-{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>FILESETS.;1)
-
-
-(* ; "
-Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1998 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT FILESETSCOMS)
-
-(RPAQQ FILESETSCOMS (
-
-(* ;;; "contains all of the lists of files which are used in various ways")
-
-                         
-                         (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel")
-
-                         (VARS * FILESETS)
-                         (VARS EXPORTFILES)
-                         (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES 
-                               DATABASEFILES)
-                         (VARS DEADFNS)))
-
-
-
-(* ;;; "contains all of the lists of files which are used in various ways")
-
-
-
-
-(* ;; 
-"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel"
-)
-
-
-(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET
-                           9LISPSET))
-
-(RPAQQ 0LISPSET 
-       (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT 
-              LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM 
-              LLREAD LLCHAR LLSTK LLDATATYPE IOCHAR LLKEY LLTIMER))
-
-(RPAQQ 1LISPSET 
-       (ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT 
-              ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS 
-              LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC
-              CMLARRAY DSK UFS UFSCALLC LLETHER PUP LEAF PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ 
-              COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS 
-              MAIKOBITBLT MAIKOINIT))
-
-(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP))
-
-(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE))
-
-(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC))
-
-(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST))
-
-(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH))
-
-(RPAQQ 7LISPSET 
-       (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT 
-              INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT 
-              CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN
-              DPUPFTP FLOPPY))
-
-(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS))
-
-(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM))
-
-(RPAQQ EXPORTFILES 
-       (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW 
-              LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY 
-              ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER
-              LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS))
-
-(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))
-
-(RPAQQ MAKEINITTYPES 
-       ((NIL INIT (0 1)
-             2LISPSET 1600)
-        (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD 
-                                    LLCHAR TINYPATCH))
-        (MACROTEST MACROTEST ((MACROTEST)
-                              0 1)
-               2LISPSET)
-        (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS)))
-        (NANOTEST NANOTEST ((MICROTEST LLSUBRS)))
-        (NULL NULL ((DUMMY)))
-        (MILLITEST MILLITEST
-               ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT 
-                       LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ)))
-        (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1)
-               2LISPSET)))
-
-(RPAQQ RENAMETYPES 
-       ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS
-                  MODARITH LLFAULT LLKEY LLBFS LLTIMER)
-           (RENAMEDFILE . I-NEW)
-           (SUBNAME . MKI.SUBFNS)
-           (COMSNAME . INEWCOMS)
-           (EXTRACOMS (VARS INITPTRS INITVALUES)
-                  (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
-                                                          MAKEINIT)))
-           (MKI.SUBFNS)
-           (INEWCOMS)
-           (VALUES . INITVALUES)
-           (PTRS . INITPTRS)
-           (PREFIX . I.)
-           (VAG2FN . I.VAG2))
-        (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK 
-                  RENAMEMACROS MODARITH LLFAULT)
-           (RENAMEDFILE . RDSYS)
-           (SUBNAME . RD.SUBFNS)
-           (COMSNAME . RDCOMS)
-           (EXTRACOMS 
-
-                  (* ;; "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)")
-
-                  (FILES VMEM)
-                  (VARS RDVALS RDPTRS)
-                  (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
-                                                          VMEM)))
-           (RD.SUBFNS (\CALLME . *))
-           (RDCOMS)
-           (PTRS . RDPTRS)
-           (PREFIX . V)
-           (VAG2FN . VVAG2)
-           (VALUES . RDVALS)
-           (RDPTRS)
-           (RDVALUES))))
-
-(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10
-                           DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX))
-
-(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM))
-
-(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE)
-                                (3LISPSET DLAP)
-                                (4LISPSET DFILE DMISC)
-                                7LISPSET
-                                (8LISPSET MAKEINIT MEM)
-                                9LISPSET
-                                (10LISPSET LLPARAMS)
-                                (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE)))
-
-(RPAQQ DEADFNS ((PUTBASE \PUTBASE)
-                    (GETBASE \GETBASE)
-                    (ADDBASE \ADDBASE)
-                    (GETBASEBYTE \GETBASEBYTE)
-                    (PUTBASEBYTE \PUTBASEBYTE)
-                    (PUTBASEPTR \PUTBASEPTR)
-                    (HILOC \HILOC)
-                    (LOLOC \LOLOC)
-                    (VAG2 \VAG2)
-                    (PAGEBASE NIL)
-                    (PAGELOC NIL)
-                    (WordsPerPage WORDSPERPAGE)
-                    (ALTOMACRO DMACRO)
-                    (\STACKSPACE ??)
-                    (GETBASEPTR \GETBASEPTR)
-                    (FPLUS2)
-                    (FTIMES2)
-                    (CREATECELL \CREATECELL)))
-(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 
-1998))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 7-Feb-2021 20:03:00" {DSK}<home>larry>ilisp>medley>sources>FILESETS.;3 7121   

      changes to%:  (VARS 1LISPSET)

      previous date%: " 7-Feb-2021 19:45:53" {DSK}<home>larry>ilisp>medley>sources>FILESETS.;2)


(* ; "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1998, 2021 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT FILESETSCOMS)

(RPAQQ FILESETSCOMS (

(* ;;; "contains all of the lists of files which are used in various ways")

                         
                         (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel")

                         (VARS * FILESETS)
                         (VARS EXPORTFILES)
                         (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES 
                               DATABASEFILES)
                         (VARS DEADFNS)))



(* ;;; "contains all of the lists of files which are used in various ways")




(* ;; 
"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel"
)


(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET
                           9LISPSET))

(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC
                           LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS 
                           LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE IOCHAR LLKEY 
                           LLTIMER))

(RPAQQ 1LISPSET
       (ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK ATERM APRINT ABASIC 
              AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART 
              LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY
              DSK UFS UFSCALLC PASSWORDS FONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST
              CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT))

(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP))

(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE))

(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC))

(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST))

(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH))

(RPAQQ 7LISPSET
       (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT 
              INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT 
              CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN
              DPUPFTP FLOPPY))

(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS))

(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM))

(RPAQQ EXPORTFILES
       (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW 
              LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY 
              ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER
              LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS))

(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))

(RPAQQ MAKEINITTYPES
       ((NIL INIT (0 1)
             2LISPSET 1600)
        (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD 
                                    LLCHAR TINYPATCH))
        (MACROTEST MACROTEST ((MACROTEST)
                              0 1)
               2LISPSET)
        (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS)))
        (NANOTEST NANOTEST ((MICROTEST LLSUBRS)))
        (NULL NULL ((DUMMY)))
        (MILLITEST MILLITEST
               ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT 
                       LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ)))
        (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1)
               2LISPSET)))

(RPAQQ RENAMETYPES
       ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS
                  MODARITH LLFAULT LLKEY LLBFS LLTIMER)
           (RENAMEDFILE . I-NEW)
           (SUBNAME . MKI.SUBFNS)
           (COMSNAME . INEWCOMS)
           (EXTRACOMS (VARS INITPTRS INITVALUES)
                  (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                          MAKEINIT)))
           (MKI.SUBFNS)
           (INEWCOMS)
           (VALUES . INITVALUES)
           (PTRS . INITPTRS)
           (PREFIX . I.)
           (VAG2FN . I.VAG2))
        (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK 
                  RENAMEMACROS MODARITH LLFAULT)
           (RENAMEDFILE . RDSYS)
           (SUBNAME . RD.SUBFNS)
           (COMSNAME . RDCOMS)
           (EXTRACOMS 

                  (* ;; "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)")

                  (FILES VMEM)
                  (VARS RDVALS RDPTRS)
                  (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                          VMEM)))
           (RD.SUBFNS (\CALLME . *))
           (RDCOMS)
           (PTRS . RDPTRS)
           (PREFIX . V)
           (VAG2FN . VVAG2)
           (VALUES . RDVALS)
           (RDPTRS)
           (RDVALUES))))

(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10
                           DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX))

(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM))

(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE)
                                (3LISPSET DLAP)
                                (4LISPSET DFILE DMISC)
                                7LISPSET
                                (8LISPSET MAKEINIT MEM)
                                9LISPSET
                                (10LISPSET LLPARAMS)
                                (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE)))

(RPAQQ DEADFNS
       ((PUTBASE \PUTBASE)
        (GETBASE \GETBASE)
        (ADDBASE \ADDBASE)
        (GETBASEBYTE \GETBASEBYTE)
        (PUTBASEBYTE \PUTBASEBYTE)
        (PUTBASEPTR \PUTBASEPTR)
        (HILOC \HILOC)
        (LOLOC \LOLOC)
        (VAG2 \VAG2)
        (PAGEBASE NIL)
        (PAGELOC NIL)
        (WordsPerPage WORDSPERPAGE)
        (ALTOMACRO DMACRO)
        (\STACKSPACE ??)
        (GETBASEPTR \GETBASEPTR)
        (FPLUS2)
        (FTIMES2)
        (CREATECELL \CREATECELL)))
(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 
1998 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/sources/FONT b/sources/FONT
index b530eb3f..85104564 100644
--- a/sources/FONT
+++ b/sources/FONT
@@ -1 +1 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "28-Jun-99 16:29:49" {DSK}<project>medley3.5>sources>FONT.;3 187933 

      changes to%:  (FNS \LOOKUPFONTSINCORE)

      previous date%: "28-Jun-99 16:22:27" {DSK}<project>medley3.5>sources>FONT.;2)


(* ; "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1999 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT FONTCOMS)

(RPAQQ FONTCOMS
       [
        (* ;; "font functions ")

        (FNS CHARWIDTH CHARWIDTHY STRINGWIDTH \CHARWIDTH.DISPLAY \STRINGWIDTH.DISPLAY 
             \STRINGWIDTH.GENERIC)
        (FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT)
        [COMS                                                (* ; 
                                                           "Until we pin down the exact interface")
              (P (MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT)
                 (MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT]
        [COMS                                                (* ; "MAPPING FOR DOS FILENAMES ")
              (INITVARS (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR)
                                                   (HELVETICA . HV)
                                                   (TIMESROMAND . TD)
                                                   (HELVETICAD . HD)
                                                   (MODERN . MD)
                                                   (CLASSIC . CL)
                                                   (GACHA . GC)
                                                   (TITAN . TI)
                                                   (LETTERGOTHIC . LG)
                                                   (BOLDPS . BP)
                                                   (TERMINAL . TM)
                                                   (CLASSICTHIN . CT)
                                                   (HIPPO . HP)
                                                   (LOGO . LG)
                                                   (MATH . MA)
                                                   (OLDENGLISH . OE)
                                                   (SYMBOL . SY]
        (COMS 
              (* ;; "Creation: ")

              (FNS FONTCREATE \FONT.SYMBOLMEMB \FONT.SYMBOLASSOC \FONT.COMPARESYMBOL))
        (COMS 
              (* ;; "Property extraction:")

              (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH))
        (COMS 
              (* ;; "Bitmap editing/manipulation:")

              (FNS GETCHARBITMAP PUTCHARBITMAP MOVECHARBITMAP))
        (FNS FONTCOPY FONTSAVAILABLE FONTFILEFORMAT FONTP FONTUNPARSE SETFONTDESCRIPTOR CHARCODEP 
             EDITCHAR \STREAMCHARWIDTH \UNITWIDTHSVECTOR \CREATEDISPLAYFONT \CREATECHARSET.DISPLAY 
             \CREATE-REAL-CHARSET.DISPLAY \BUILDSLUGCSINFO \SEARCHDISPLAYFONTFILES \SEARCHFONTFILES 
             \FINDFONTFILE \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR \FONTFILENAME 
             \FONTFILENAME.OLD \FONTFILENAME.NEW \FONTINFOFROMFILENAME \FONTINFOFROMFILENAME.OLD 
             \GETFONTDESC \COERCEFONTDESC \LOOKUPFONT \LOOKUPFONTSINCORE \READDISPLAYFONTFILE)
        (COMS 
              (* ;; "\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories.  That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places.  ")

              (ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE))
              (INITVARS (*USEOLDFONTDIRECTORIES* NIL))
              (GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)
              
              (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)")
)
        (COMS 
              (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)")

              (INITVARS (CACHEDISPLAYFONTS T))
              (GLOBALVARS CACHEDISPLAYFONTS)
                                                             (* ; "STRIKE format file support")
              (FNS \READSTRIKEFONTFILE \SFMAKEBOLD \SFMAKEITALIC \SFMAKEROTATEDFONT \SFROTATECSINFO 
                   \SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION \SFROTATECSINFOOFFSETS 
                   \SFMAKECOLOR)
              (FNS WRITESTRIKEFONTFILE STRIKECSINFO))
        (INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
        (SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
        (INITVARS (\FONTSINCORE)
               (\DEFAULTDEVICEFONTS)
               (\UNITWIDTHSVECTOR))
        (GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\UNITWIDTHSVECTOR)))
        (CONSTANTS (NORUNCODE 255))
        (EXPORT (OPTIMIZERS FONTPROP))
        [DECLARE%: DONTCOPY
               (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO)
                      (MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET \FGETWIDTH 
                             \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH \FGETIMAGEWIDTH \FSETIMAGEWIDTH
                             \GETCHARSETINFO \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR)
                      (FUNCTIONS \CREATEKERNELEMENT \FSETLEFTKERN \FGETLEFTKERN)
                      (CONSTANTS (\MAXNSCHAR 65535]
        (COMS                                                (* ; "NS Character specific code")
              (FNS \CREATECHARSET)
              (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS 
                     MISSINGCHARSETDISPLAYFONTCOERCIONS CHARSETERRORFLG)
              (INITVARS (DISPLAYFONTCOERCIONS NIL)
                     [MISSINGCHARSETDISPLAYFONTCOERCIONS '(((GACHA)
                                                            (TERMINAL))
                                                           ((MODERN)
                                                            (CLASSIC))
                                                           ((TIMESROMAN)
                                                            (CLASSIC))
                                                           ((HELVETICA)
                                                            (MODERN))
                                                           ((TERMINAL 6)
                                                            (MODERN 6))
                                                           ((TERMINAL 8)
                                                            (MODERN 8))
                                                           ((TERMINAL 10)
                                                            (MODERN 10))
                                                           ((TERMINAL 12)
                                                            (MODERN 12]
                     [MISSINGDISPLAYFONTCOERCIONS '(((GACHA)
                                                     (TERMINAL))
                                                    ((MODERN)
                                                     (CLASSIC))
                                                    ((TIMESROMAN)
                                                     (CLASSIC))
                                                    ((HELVETICA)
                                                     (MODERN]
                     (CHARSETERRORFLG NIL)
                     (\DEFAULTCHARSET 0)))
        (FNS \FONTRESETCHARWIDTHS)
        [DECLARE%: DONTEVAL@LOAD (INITVARS (DISPLAYFONTEXTENSIONS 'DISPLAYFONT)
                                        (DISPLAYFONTDIRECTORIES '(
                                                      {DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/
                                                                  
                                                        {dsk}/usr/local/lde/fonts/display/publishing/
                                                                  ]
        (MACROS \FGETCHARIMAGEWIDTH \GETFONTDESC \SETCHARSETINFO)
        (LOCALVARS . T)
        (PROP FILETYPE FONT)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA FONTCOPY])



(* ;; "font functions ")

(DEFINEQ

(CHARWIDTH
  [LAMBDA (CHARCODE FONT)                                (* rmk%: "12-Apr-85 09:46")
                                                             (* ; 
                                              "gets the width of a character code in a font/stream")
    (OR (\CHARCODEP CHARCODE)
        (\ILLEGAL.ARG CHARCODE))
    (LET (TEMP)
         (COND
            ((type? FONTDESCRIPTOR FONT)
             (\FGETCHARWIDTH FONT CHARCODE))
            ((SETQ TEMP (\OUTSTREAMARG FONT T))              (* ; 
                                                     "NIL font goes thru here--primary output file")
             (IMAGEOP 'IMCHARWIDTH TEMP TEMP CHARCODE))
            (T (\FGETCHARWIDTH (FONTCREATE FONT)
                      CHARCODE])

(CHARWIDTHY
  [LAMBDA (CHARCODE FONT)                                (* edited%: "18-Mar-86 19:30")
                                                             (* ; 
                                 "Gets the Y-component of the width of a character code in a font.")
    (OR (\CHARCODEP CHARCODE)
        (\ILLEGAL.ARG CHARCODE))
    (LET (TEMP WY)
         (COND
            ((type? FONTDESCRIPTOR FONT)
             (SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                      FONT)))
             (COND
                ((FIXP WY))
                (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
                (T 0)))
            ((type? STREAM (SETQ TEMP (\OUTSTREAMARG FONT T)))
                                                             (* ; 
                                                     "NIL font goes thru here--primary output file")
             (IMAGEOP 'IMCHARWIDTHY TEMP TEMP CHARCODE))
            (T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                        (FONTCREATE FONT]
               (COND
                  ((FIXP WY))
                  (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
                  (T 0])

(STRINGWIDTH
  [LAMBDA (STR FONT FLG RDTBL)                           (* ; "Edited  8-Jan-88 14:41 by Snow")

    (* ;; "Returns the width of STR according to FONT")

    (LET (TEMP)

         (* ;; "Used in \MAPCHARS")

         (COND
            [(type? FONTDESCRIPTOR FONT)
             (\STRINGWIDTH.GENERIC STR FONT (AND FLG (\GTREADTABLE RDTBL))
                    (\FGETCHARWIDTH FONT (CHARCODE SPACE]
            [(AND FONT (SETQ TEMP (\OUTSTREAMARG FONT T)))   (* ; 
  "if you gave something for FONT, coerce it to a stream, and call the stringwidth function of it.")
             (IMAGEOP 'IMSTRINGWIDTH TEMP TEMP STR (AND FLG (\GTREADTABLE RDTBL]
            (T (SETQ TEMP (FONTCREATE (OR FONT DEFAULTFONT)))
                                                             (* ; "NIL font will pass thru here.  ie, defaultfont is used to do the stringwidth instead of the font of *standard-output*")
               (\STRINGWIDTH.GENERIC STR TEMP (AND FLG (\GTREADTABLE RDTBL))
                      (\FGETCHARWIDTH TEMP (CHARCODE SPACE])

(\CHARWIDTH.DISPLAY
  [LAMBDA (STREAM CHARCODE)                              (* rmk%: "12-Apr-85 09:42")
                                                             (* ; 
         "gets the width of a character code in a display stream.  Need to fix up for spacefactor.")
    (\FGETCHARWIDTH (ffetch (\DISPLAYDATA DDFONT) of (ffetch IMAGEDATA of STREAM))
           CHARCODE])

(\STRINGWIDTH.DISPLAY
  [LAMBDA (STREAM STR RDTBL)                             (* ; "Edited  3-Apr-87 12:07 by jop")

    (* ;; "Returns the width of for the current font/spacefactor in STREAM.")

    (LET ((DD (ffetch IMAGEDATA of STREAM)))
         (\STRINGWIDTH.GENERIC STR (ffetch (\DISPLAYDATA DDFONT) of DD)
                RDTBL
                (ffetch DDSPACEWIDTH of DD])

(\STRINGWIDTH.GENERIC
  [LAMBDA (STR FONT RDTBL SPACEWIDTH)                    (* ; "Edited  3-Apr-87 13:47 by jop")

    (* ;; "Returns the width of STR with SPACEWIDTH for the width of spaces.  RDTBL has already been coerced, so no FLG is needed ")

    (* ;; "This is cloned in \STRINGWIDTH.HCPYDISPLAYAUX by straight substitution -- (PUTDEF (QUOTE \STRINGWIDTH.HCPYDISPLAYAUX) (QUOTE FNS) (SUBLIS (QUOTE ((WIDTHS  . IMAGEWIDTHS) (\FGETWIDTH  . \FGETIMAGEWIDTH) (\FGETCHARWIDTH  . \FGETCHARIMAGEWIDTH))) (GETDEF (QUOTE \STRINGWIDTH.GENERIC))))")

    (* ;; "\MAPPNAME uses WIDTHSBASE CSET TOTALWIDTH FONT SPACEWIDTH free, so these become special in bytecompiler")

    (PROG NIL
          [COND
             [(LITATOM STR)
              (if RDTBL
                  then (GO SLOW)
                else (RETURN (for C WIDTHSBASE CSET inatom STR
                                    sum [COND
                                               ((NEQ CSET (\CHARSET C))
                                                (SETQ CSET (\CHARSET C))
                                                (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
                                                                    of (\GETCHARSETINFO CSET FONT
                                                                                  ]
                                          (COND
                                             ((EQ C (CHARCODE SPACE))
                                              SPACEWIDTH)
                                             (T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C]
             ((STRINGP STR)
              (RETURN
               (LET ((TOTAL 0)
                     ESC ESCWIDTH WIDTHSBASE CSET)
                    [COND
                       (RDTBL                                (* ; 
                                                     "Count delimiting quotes and internal escapes")
                              (SETQ TOTAL (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %"))
                                                 2))
                              (SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL))
                              (SETQ ESCWIDTH (\FGETCHARWIDTH FONT ESC]
                    [for C instring STR
                       do [COND
                                 ((NEQ (\CHARSET C)
                                       CSET)                 (* ; 
                                                     "Get the widths vector for this character set")
                                  (SETQ CSET (\CHARSET C))
                                  (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
                                                      of (\GETCHARSETINFO CSET FONT]
                             (add TOTAL (COND
                                               ((EQ C (CHARCODE SPACE))
                                                SPACEWIDTH)
                                               (T (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C))
                                                         (COND
                                                            ((AND RDTBL (OR (EQ C (CHARCODE %"))
                                                                            (EQ C ESC)))
                                                             (* ; "String char must be escaped")
                                                             ESCWIDTH)
                                                            (T 0]
                    TOTAL]
      SLOW
                                                             (* ; "Do the general case here")
          (RETURN (LET ((TOTALWIDTH 0)
                        WIDTHSBASE CSET (FONT FONT)
                        (SPACEWIDTH SPACEWIDTH))
                       (DECLARE (SPECVARS TOTALWIDTH WIDTHSBASE CSET FONT SPACEWIDTH))
                       (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CC)
                                              (add TOTALWIDTH (COND
                                                                     ((EQ CC (CHARCODE SPACE))
                                                                      SPACEWIDTH)
                                                                     ((EQ CSET (\CHARSET CC))
                                                                      (\FGETWIDTH WIDTHSBASE
                                                                             (\CHAR8CODE CC)))
                                                                     (T (SETQ CSET (\CHARSET CC))
                                                                        (SETQ WIDTHSBASE
                                                                         (ffetch (CHARSETINFO
                                                                                      WIDTHS)
                                                                            of (\GETCHARSETINFO
                                                                                    CSET FONT)))
                                                                        (\FGETWIDTH WIDTHSBASE
                                                                               (\CHAR8CODE CC]
                              STR RDTBL RDTBL *PRINT-LEVEL* *PRINT-LENGTH*)
                       TOTALWIDTH])
)
(DEFINEQ

(DEFAULTFONT
  [LAMBDA (DEVICE FONT NOERRORFLG)                       (* ; "Edited 28-Jul-88 13:15 by rmk:")
                                                             (* ; "Edited 24-Mar-87 14:41 by FS")

    (* ;; "Returns the default font for an image type.  Really only needed to guarantee validity of the display default font for system critical routines, in case the user has smashed the variable DEFAULTFONT.  Note that SETFONTCLASSCOMPONENT and FONTCLASS guarantee that the display component is either NIL or a fontdescriptor.")

    (* ;; "FS- If FONT provided set the font descriptor.  Do not bother to check if NOERRORFLG is NEW. (old code had (AND FONT (EQ NOERRORFLG 'NEW)))")

    [OR (type? FONTCLASS DEFAULTFONT)
        (SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT]
    (if FONT
        then 

              (* ;; "FS- Not clear the fontclass should be smashed, perhaps instead should make a new FONTCLASS and then rebind DEFAULTFONT.  Leaving alone for histerical reasons")

              (SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE FONT)
      else 

            (* ;; "The code below (not mine!) is messy but is correct (unless weirdness pops up because of deep recursion).")

            (COND
               ((\COERCEFONTDESC DEFAULTFONT DEVICE T))
               (NOERRORFLG NIL)
               ((EQ (\DEVICESYMBOL DEVICE T)
                    'DISPLAY)

                (* ;; "If getting for the display and the font can't be found perhaps because of garbage in the display field of the DEFAULTFONTCLASS, then the system-guaranteed displayfont.  Otherwise, cause the error in the re-coercion.  Can never tell when DEVICE is just a symbol.")

                \GUARANTEEDDISPLAYFONT)
               ((\COERCEFONTDESC DEFAULTFONT DEVICE])

(FONTCLASS
  [LAMBDA (NAME FONTLIST CREATEFORDEVICES)               (* jds " 9-Sep-86 18:49")

    (* ;; "This builds D style font classes, which are datatypes containing entries for the various known devices.")

    (* ;; "Don't actually set up the for devices not inside CREATEFORDEVICES on the theory that any given user presumably doesn't want all the fonts for all the devices.  We wait until he actually asks for the font or the fontmaparray, at which point we note that the fields don't contain FD's, so we then apply FONTCREATE.  The actual coercion and caching is done inside \COERCEFONTDESC.  However, so as to prevent display crashes, if a display component is specified, we always do the fontcreate before we stick it in.")

    (PROG (F FC FL)
          (SETQ FL FONTLIST)
          [SETQ FC (create FONTCLASS
                          FONTCLASSNAME _ NAME
                          PRETTYFONT# _ (OR (FIXP (pop FL))
                                            1)
                          DISPLAYFD _ (AND (SETQ F (pop FL))
                                           (FONTCREATE F NIL NIL NIL 'DISPLAY))
                          PRESSFD _ (pop FL)
                          INTERPRESSFD _ (pop FL)
                          OTHERFDS _ (for FSPEC in FL
                                        collect (OR (AND (LISTP FSPEC)
                                                             (ATOM (CAR FSPEC))
                                                             (CAR FSPEC))
                                                        (ERROR "illegal font class specification"
                                                               (LIST NAME FONTLIST))) 
                                                             (* ; 
                                     "Copy the alist entry so it can be smashed in \COERCEFONTDESC")
                                              (CONS (CAR FSPEC)
                                                    (CAR (LISTP (CDR FSPEC]
          (for D inside CREATEFORDEVICES do (FONTCREATE FC NIL NIL NIL D))
          (RETURN FC])

(FONTCLASSUNPARSE
  [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG)         (* jds "24-Jan-86 11:58")
                                                             (* ; 
                                "Given a font class, unparse it to a form that might be reparsable")
    (APPEND (LIST (fetch (FONTCLASS FONTCLASSNAME) of FONTCLASS)
                  (fetch (FONTCLASS PRETTYFONT#) of FONTCLASS)
                  (FONTUNPARSE (ffetch (FONTCLASS DISPLAYFD) of FONTCLASS))
                  (FONTUNPARSE (ffetch (FONTCLASS PRESSFD) of FONTCLASS))
                  (FONTUNPARSE (ffetch (FONTCLASS INTERPRESSFD) of FONTCLASS)))
           (for X in (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
              collect (LIST (CAR X)
                                (FONTUNPARSE (CDR X])

(FONTCLASSCOMPONENT
  [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG)         (* rmk%: "14-Sep-84 19:34")
    (PROG1 (FONTCREATE FONTCLASS NIL NIL NIL DEVICE NOERRORFLG)
                                                             (* ; 
                    "This works its way down to \COERCEFONTDESC, where it needs to be done quickly")
        (AND FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL DEVICE NOERRORFLG))
             (SETFONTCLASSCOMPONENT FONTCLASS DEVICE FONT)))])

(SETFONTCLASSCOMPONENT
  [LAMBDA (FONTCLASS DEVICE FONT)                    (* ; "Edited 29-Aug-91 12:20 by jds")
    (PROG ((NEWFONT (FONTCREATE FONT NIL NIL NIL DEVICE)))

     (* ;; "replaces will barf if FONTCLASS is not a fontclass")

          (SELECTQ (SETQ DEVICE (FONTPROP NEWFONT 'DEVICE))
              (DISPLAY (replace (FONTCLASS DISPLAYFD) of FONTCLASS with NEWFONT))
              (INTERPRESS (replace (FONTCLASS INTERPRESSFD) of FONTCLASS with NEWFONT
                                 ))
              (PRESS (replace (FONTCLASS PRESSFD) of FONTCLASS with NEWFONT))
              (RPLACD [OR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of FONTCLASS))
                          (CAR (push (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
                                      (CONS DEVICE]
                     NEWFONT))
          (RETURN NEWFONT])
)



(* ; "Until we pin down the exact interface")


(MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT)

(MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT)



(* ; "MAPPING FOR DOS FILENAMES ")


(RPAQ? *DISPLAY-FONT-NAME-MAP*
       '((TIMESROMAN . TR)
         (HELVETICA . HV)
         (TIMESROMAND . TD)
         (HELVETICAD . HD)
         (MODERN . MD)
         (CLASSIC . CL)
         (GACHA . GC)
         (TITAN . TI)
         (LETTERGOTHIC . LG)
         (BOLDPS . BP)
         (TERMINAL . TM)
         (CLASSICTHIN . CT)
         (HIPPO . HP)
         (LOGO . LG)
         (MATH . MA)
         (OLDENGLISH . OE)
         (SYMBOL . SY)))



(* ;; "Creation: ")

(DEFINEQ

(FONTCREATE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)
                                                             (* ; "Edited 10-Oct-88 09:53 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:43 by rmk:")
                                                             (* ; "Edited 10-Nov-87 18:08 by FS")

    (* ;; "Create a font descriptor for the specified font.  If NOERRORFLG, return NIL if the font doesn't exist;  otherwise cause an error.")

    (* ;; "Cache and fonts.widths traffic in uppercase only.")

    (* ;; "character set is optional and defaults to \DEFAULTCHARSET (0 in our world)")

    (DECLARE (GLOBALVARS IMAGESTREAMTYPES \DEFAULTCHARSET))
    (PROG (FONTX (CHSET (OR CHARSET \DEFAULTCHARSET)))
          (RETURN (COND
                     ((LISTP FAMILY)
                      (SELECTQ (CAR FAMILY)
                          (FONT (SETQ FONTX (CDR FAMILY)))
                          (CLASS (COND
                                    ((LITATOM (CADR FAMILY)) (* ; "litatom class name")
                                     (RETURN (FONTCLASS (CADR FAMILY)
                                                    (CDDR FAMILY)
                                                    DEVICE)))
                                    (T                       (* ; 
                     "Allows for a font named CLASS--distinguished cause its size is not a litatom")
                                       (SETQ FONTX FAMILY))))
                          (SETQ FONTX FAMILY))
                      (FONTCREATE (CAR FONTX)
                             (OR (CADR FONTX)
                                 SIZE)
                             (OR (CADDR FONTX)
                                 FACE)
                             (OR (CADDDR FONTX)
                                 ROTATION)
                             (OR (CADR (CDDDR FONTX))
                                 DEVICE)
                             NOERRORFLG CHSET))
                     ([SETQ FONTX (COND
                                     ((type? FONTDESCRIPTOR FAMILY)
                                      FAMILY)
                                     ((NULL FAMILY)
                                      (DEFAULTFONT DEVICE))
                                     ((type? FONTCLASS FAMILY)

                                 (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.  Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.")

                                      (\COERCEFONTDESC FAMILY DEVICE NOERRORFLG))
                                     ((OR (IMAGESTREAMP FAMILY)
                                          (type? WINDOW FAMILY))
                                      (DSPFONT NIL FAMILY]

                      (* ;; 
                 "FAMILY was a spec for a font descriptor, use it and extend it by the other args.")

                      (COND
                         ((OR SIZE FACE ROTATION DEVICE)
                          (FONTCREATE (FONTPROP FONTX 'FAMILY)
                                 (OR SIZE (FONTPROP FONTX 'SIZE))
                                 (OR FACE (FONTPROP FONTX 'FACE))
                                 (OR ROTATION (FONTPROP FONTX 'ROTATION))
                                 (OR DEVICE (FONTPROP FONTX 'DEVICE))
                                 NOERRORFLG))
                         (T FONTX)))
                     (T (PROG (FONTFACE (DEV DEVICE))
                          RETRY
                              [OR (LITATOM FAMILY)
                                  (COND
                                     (NOERRORFLG (RETURN))
                                     (T (LISPERROR "ARG NOT LITATOM" FAMILY T]
                              [OR (AND (FIXP SIZE)
                                       (IGREATERP SIZE 0))
                                  (COND
                                     (NOERRORFLG (RETURN NIL))
                                     (T (\ILLEGAL.ARG SIZE]
                              (COND
                                 ((NULL ROTATION)
                                  (SETQ ROTATION 0))
                                 ((AND (FIXP ROTATION)
                                       (IGEQ ROTATION 0)))
                                 (NOERRORFLG (RETURN NIL))
                                 (T (\ILLEGAL.ARG ROTATION)))
                              [SETQ DEV (COND
                                           ((NULL DEVICE)
                                            'DISPLAY)
                                           ((AND (LITATOM DEVICE)
                                                 (NEQ DEVICE T))
                                                             (* ; 
"Maybe wrong case or package, but we bet it's OK and defer  expensive coercion until we've failed.")
                                            DEV)
                                           ((SETQ DEV (\GETSTREAM DEVICE 'OUTPUT T))
                                                             (* ; 
                                                           "T coerces here to primary output")
                                            (fetch (IMAGEOPS IMFONTCREATE)
                                               of (fetch (STREAM IMAGEOPS) of DEV)))
                                           ((STRINGP DEVICE)
                                            (MKATOM (U-CASE DEVICE)))
                                           (NOERRORFLG (RETURN NIL))
                                           (T (\ILLEGAL.ARG DEVICE]
                                                             (* ; "DEV is now guanteed litatom")
                          NEWDEV
                                                             (* ; 
                                                  "Check after device since it is device-dependent")
                              (SETQ FONTFACE (OR (\FONTFACE FACE NOERRORFLG DEV)
                                                 (RETURN NIL)))
                                                             (* ; "Don't truly coerce to \FONTSYMBOL or \DEVICESYMBOL until we've had a shot at the font cache, since re-interning atoms is so expensive")
                              [RETURN (COND
                                         ((\LOOKUPFONT FAMILY SIZE FONTFACE ROTATION DEV))
                                         [(SETQ FONTX (CDR (ASSOC DEV IMAGESTREAMTYPES)))

                                 (* ;; "Device is valid, font just doesn't exist.   FONTFACE, DEV already canonical.  Make FAMILY so, so that each imagestream type doesn't have to.")

                                          (SETQ FAMILY (\FONTSYMBOL FAMILY))
                                          (COND
                                             ((SETQ FONTX (APPLY* (OR (CADR (ASSOC 'FONTCREATE FONTX)
                                                                            )
                                                                      (FUNCTION NILL))
                                                                 FAMILY SIZE FONTFACE ROTATION DEV 
                                                                 CHSET))

                                      (* ;; "default creation case.  Use fontcreate method from device, build a fontdescriptor and use setfontdescriptor to install it.")

                                 (* ;; "OBSOLETEd by the CHARSETINFO code (OR (ffetch FONTIMAGEWIDTHS of FONTX) (freplace FONTIMAGEWIDTHS of FONTX with (ffetch \SFWidths of FONTX)))")

                                              (* ;; 
             "the widths fields in the fontdescriptor are obsolete, and shoudln't be updated here.")

                                           (* ;; "We should probably force all device implementations to obey these conventions, then remove these generic updates")

                                              (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH)
                                                 of FONTX with (\AVGCHARWIDTH FONTX))
                                              (SETFONTDESCRIPTOR FAMILY SIZE FONTFACE ROTATION 
                                                     DEV FONTX))
                                             (T (GO NOTFOUND]
                                         ((NEQ DEV (SETQ DEV (U-CASE DEV)))

                                 (* ;; "We didn't recognize the device, so check to see whether coercion to U-CASE IL changes anything.  Could be slow, but we're heading for an error.")

                                          (GO NEWDEV))
                                         (T (GO NOTFOUND]
                          NOTFOUND
                              (COND
                                 (NOERRORFLG (RETURN NIL))
                                 (T (ERROR "FONT NOT FOUND (coerced to)"
                                           (LIST FAMILY SIZE FONTFACE ROTATION DEV))
                                    (GO RETRY])

(\FONT.SYMBOLMEMB
  [LAMBDA (USERINPUT LIST)                               (* ; "Edited  7-Feb-89 15:47 by jds")
    (for X on LIST when (\FONT.COMPARESYMBOL USERINPUT (CAR X))
       do (RETURN X])

(\FONT.SYMBOLASSOC
  [LAMBDA (USERINPUT LIST)                               (* ; "Edited 28-Jul-88 16:56 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:15 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:03 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:16 by rmk:")
    (for X FIRSTC (NC _ (NCHARS USERINPUT)) in LIST
       first (SETQ FIRSTC (CHCON1 USERINPUT))
             [if (AND (IGEQ FIRSTC (CHARCODE a))
                          (ILEQ FIRSTC (CHARCODE z)))
                 then (SETQ FIRSTC (IDIFFERENCE FIRSTC (IDIFFERENCE (CHARCODE a)
                                                                  (CHARCODE A]
       when (AND (EQ NC (NCHARS (CAR X)))
                     (EQ FIRSTC (CHCON1 (CAR X)))
                     (\FONT.COMPARESYMBOL USERINPUT (CAR X)
                            NC FIRSTC)) do (RETURN X])

(\FONT.COMPARESYMBOL
  [LAMBDA (USERINPUT KEY INPUTNC INPUTFIRSTC) (* ; 
                                                "Edited 24-May-93 16:45 by sybalsky:mv:envos")

    (* ;; " An open coded case- and package-insensitive comparison of atom pnames, assuming that KEY is already upper-case but USERINPUT may not be.  Maybe there is a simple function that does this.")

    (* ;; "INPUTNC and INPUTFIRSTC can be passed in if they are common to lots of calls")

    (COND
       ((AND (LITATOM USERINPUT)
             (EQ [CL:AREF *PACKAGE-FROM-INDEX* (fetch (PNAMECELL PACKAGEINDEX)
                                                  of (PROGN (\PNAMECELL USERINPUT]
                 *INTERLISP-PACKAGE*))

        (* ;; "If the user's symbol is in the IL package (which is where all the KEYs are), we can use EQ, which is MUCH faster.")

        (OR (EQ USERINPUT KEY)
            (EQ (U-CASE USERINPUT)
                KEY)))
       (T 
          (* ;; "Otherwise, we do the comparison character by character.")

          (AND (EQ (OR INPUTNC (NCHARS USERINPUT))
                   (NCHARS KEY))
               [COND
                  (INPUTFIRSTC (EQ INPUTFIRSTC (CHCON1 KEY)))
                  ((EQ (SETQ INPUTFIRSTC (CHCON1 USERINPUT))
                       (CHCON1 KEY)))
                  ((AND (IGEQ INPUTFIRSTC (CHARCODE a))
                        (ILEQ INPUTFIRSTC (CHARCODE z)))
                   (EQ (IDIFFERENCE INPUTFIRSTC (IDIFFERENCE (CHARCODE a)
                                                       (CHARCODE A)))
                       (CHCON1 KEY]
               (for CHAR1 inatom USERINPUT as CHAR2 inatom KEY
                  always (OR (EQ CHAR1 CHAR2)
                                 (AND (IGEQ CHAR1 (CHARCODE a))
                                      (ILEQ CHAR1 (CHARCODE z))
                                      (EQ CHAR2 (IPLUS CHAR1 (CONSTANT (IDIFFERENCE (CHARCODE A)
                                                                              (CHARCODE a])
)



(* ;; "Property extraction:")

(DEFINEQ

(FONTASCENT
  [LAMBDA (FONTSPEC)                                     (* lmm "19-NOV-82 00:23")
    (ffetch \SFAscent of (\GETFONTDESC FONTSPEC])

(FONTDESCENT
  [LAMBDA (FONTSPEC)                                     (* lmm "19-NOV-82 00:24")
                                                             (* ; "See comment in FONTASCENT")
    (ffetch \SFDescent of (\GETFONTDESC FONTSPEC])

(FONTHEIGHT
  [LAMBDA (FONTSPEC)                                     (* kbr%: " 9-Jan-86 18:29")
    (fetch (FONTDESCRIPTOR \SFHeight) of (\GETFONTDESC FONTSPEC])

(FONTPROP
  [LAMBDA (FONT PROP)                                    (* kbr%: "13-May-85 22:36")
    (SETQ FONT (\GETFONTDESC FONT))
    (SELECTQ PROP
        (HEIGHT (ffetch \SFHeight of FONT))
        (ASCENT (ffetch \SFAscent of FONT))
        (DESCENT (ffetch \SFDescent of FONT))
        (FAMILY (ffetch FONTFAMILY of FONT))
        (SIZE (ffetch FONTSIZE of FONT))
        (FACE (COPY (ffetch FONTFACE of FONT)))
        (WEIGHT (ffetch WEIGHT of (ffetch FONTFACE of FONT)))
        (SLOPE (ffetch SLOPE of (ffetch FONTFACE of FONT)))
        (EXPANSION (ffetch EXPANSION of (ffetch FONTFACE of FONT)))
        (FORECOLOR (ffetch FORECOLOR of (ffetch FONTFACE of FONT)))
        (BACKCOLOR (ffetch BACKCOLOR of (ffetch FONTFACE of FONT)))
        (ROTATION (ffetch ROTATION of FONT))
        (DEVICE (ffetch FONTDEVICE of FONT))
        (SPEC (LIST (ffetch FONTFAMILY of FONT)
                    (ffetch FONTSIZE of FONT)
                    (COPY (ffetch FONTFACE of FONT))
                    (ffetch ROTATION of FONT)
                    (ffetch FONTDEVICE of FONT)))
        (DEVICESPEC                                          (* ; 
                  "DEVICE fields are for communicating coercions to the particular printing device")
                    [COND
                       ((ffetch FONTDEVICESPEC of FONT)
                        (COPY (ffetch FONTDEVICESPEC of FONT)))
                       (T (FONTPROP FONT 'SPEC])
        (DEVICEFACE [COPY (COND
                             ((ffetch FONTDEVICESPEC of FONT)
                              (CADDR (ffetch FONTDEVICESPEC of FONT)))
                             (T (ffetch FONTFACE of FONT])
        (DEVICESLOPE [fetch SLOPE of (COND
                                                ((ffetch FONTDEVICESPEC of FONT)
                                                 (CADDR (ffetch FONTDEVICESPEC of FONT)))
                                                (T (ffetch FONTFACE of FONT])
        (DEVICEWEIGHT [fetch WEIGHT of (COND
                                                  ((ffetch FONTDEVICESPEC of FONT)
                                                   (CADDR (ffetch FONTDEVICESPEC of FONT)))
                                                  (T (ffetch FONTFACE of FONT])
        (DEVICEEXPANSION 
             [fetch EXPANSION of (COND
                                            ((ffetch FONTDEVICESPEC of FONT)
                                             (CADDR (ffetch FONTDEVICESPEC of FONT)))
                                            (T (ffetch FONTFACE of FONT])
        (DEVICESIZE (COND
                       ((ffetch FONTDEVICESPEC of FONT)
                        (CADR (ffetch FONTDEVICESPEC of FONT)))
                       (T (ffetch FONTSIZE of FONT))))
        (DEVICEFAMILY (COND
                         ((ffetch FONTDEVICESPEC of FONT)
                          (CAR (ffetch FONTDEVICESPEC of FONT)))
                         (T (ffetch FONTFAMILY of FONT))))
        (SCALE (ffetch FONTSCALE of FONT))
        (\ILLEGAL.ARG PROP])

(\AVGCHARWIDTH
  [LAMBDA (FONT)                                         (* rmk%: "27-Nov-84 18:40")

    (* ;; "Returns the average width of a character, to be used in units-to-characters approximations, as in fixing the linelength")

    (PROG ((W (CHARWIDTH (CHARCODE A)
                     FONT)))
          (RETURN (COND
                     ((NEQ 0 W)
                      W)
                     ([NEQ 0 (SETQ W (FIXR (FTIMES 0.6 (FONTPROP FONT 'HEIGHT]
                      W)
                     (T 1])
)



(* ;; "Bitmap editing/manipulation:")

(DEFINEQ

(GETCHARBITMAP
  [LAMBDA (CHARCODE FONT)                                (* ; "Edited 26-Apr-89 21:49 by atm")
                                                             (* ; 
                    "returns a bitmap of the character CHARCODE from the font descriptor FONTDESC.")
    (COND
       ((OR (CHARCODEP CHARCODE)
            (EQ CHARCODE 256))                               (* ; 
                                       "bitmap for char 256 is what gets printed if char not found")
        )
       ((OR (STRINGP CHARCODE)
            (LITATOM CHARCODE))                              (* ; 
                                                 "For strings & litatoms, take the first character")
        (SETQ CHARCODE (CHCON1 CHARCODE)))
       ((TYPEP CHARCODE 'CL:CHARACTER)                       (* ; 
                                   "For common-lisp CHARACTERs, convert it to the char code first.")
        (SETQ CHARCODE (CL:CHAR-INT CHARCODE)))
       (T (\ILLEGAL.ARG CHARCODE)))
    (PROG (CBM (FONTDESC (\GETFONTDESC FONT))
               CSINFO CWDTH CHGHT)

     (* ;; "fetch the csinfo for the character set of this character.  Bitmaps and widths must be fetched from it")

          (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
                              FONTDESC))

     (* ;; "(\\fgetwidth (|fetch| (charsetinfo widths) |of| csinfo) (\\char8code charcode))")

          [SETQ CBM (BITMAPCREATE [SETQ CWDTH (if (fetch (CHARSETINFO IMAGEWIDTHS)
                                                         of CSINFO)
                                                  then (\FGETIMAGEWIDTH (fetch (CHARSETINFO
                                                                                        IMAGEWIDTHS)
                                                                               of CSINFO)
                                                                  (\CHAR8CODE CHARCODE))
                                                else (\FGETWIDTH (fetch (CHARSETINFO WIDTHS)
                                                                        of CSINFO)
                                                                (\CHAR8CODE CHARCODE]
                           (SETQ CHGHT (FONTPROP FONTDESC 'HEIGHT))
                           (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CHARSETINFO
                                                                                     CHARSETBITMAP)
                                                                            of CSINFO]
          (BITBLT (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
                 (\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO)
                        (\CHAR8CODE CHARCODE))
                 0 CBM 0 0 CWDTH CHGHT)
          (RETURN CBM])

(PUTCHARBITMAP
  [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT)   (* ; "Edited 27-Apr-89 11:19 by atm")

    (* ;; "stores the bitmap NEWCHARBITMAP as the character CHARCODE from the font descriptor FONTDESC.  If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.")

    (OR (TYPENAMEP NEWCHARBITMAP 'BITMAP)
        (\ILLEGAL.ARG NEWCHARBITMAP))
    (COND
       ((CHARCODEP CHARCODE))
       ((OR (STRINGP CHARCODE)
            (LITATOM CHARCODE))
        (SETQ CHARCODE (CHCON1 CHARCODE)))
       (T (\ILLEGAL.ARG CHARCODE)))
    (PROG* ((FONTDESC (\GETFONTDESC FONT))
            (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
                           FONTDESC))
            (CDESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
            (CASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
            (CHEIGHT (IPLUS CDESCENT CASCENT))
            (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
            (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
            (IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))
            (CIMWIDTH (if IMWIDTHS
                          then (\FGETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE))
                        else NIL))
            (CWIDTH (OR CIMWIDTH (CHARWIDTH CHARCODE FONTDESC)))
            (FONTBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
            (OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP))
            TEMPBITMAP BWIDTH DW BHEIGHT BASCENT BDESCENT NDESCENT NASCENT NHEIGHT CHAROFFSET
            (BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of FONTBITMAP)))

     (* ;; "fetch the ascents and descents of the bitmap and the new maximums.")

           (SETQ BWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP))
           (SETQ BHEIGHT (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP))
           (SETQ BDESCENT (OR NEWCHARDESCENT CDESCENT))
           (SETQ BASCENT (IDIFFERENCE BHEIGHT BDESCENT))
           (SETQ NDESCENT (IMAX BDESCENT CDESCENT))
           (SETQ NASCENT (IMAX BASCENT CASCENT))
           (SETQ NHEIGHT (IPLUS NDESCENT NASCENT))
           (SETQ CHAROFFSET (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE)))

     (* ;; "set up a new target bitmap if any of the parameters have changed.")

           (COND
              ((EQ CHAROFFSET (\FGETOFFSET OFFSETS \MAXTHINCHAR))

               (* ;; "changing the bitmap for a character which formerly pointed at the slug character.  Allocate a new bitmap character bitmap for this.")

               (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH BWIDTH)
                                       NHEIGHT BITSPERPIXEL))
               (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      OFWIDTH CHEIGHT)                       (* ; "copy the old characters over.")
               (SETQ CHAROFFSET OFWIDTH))
              ((NEQ CWIDTH BWIDTH)

               (* ;; "The bitmaps differ in width;  create a new bitmap with things at the right places, then update widths and offsets.")

               (SETQ DW (IDIFFERENCE BWIDTH CWIDTH))         (* ; "Difference in character widths")
               (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW)
                                       NHEIGHT BITSPERPIXEL))(* ; 
                              "this may also be a taller bitmap if NHEIGHT is larger than CHEIGHT.")
               (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      CHAROFFSET CHEIGHT)                    (* ; 
                                                  "Copy that portion to the left of the character.")
               (BITBLT FONTBITMAP (IPLUS CHAROFFSET CWIDTH)
                      0 TEMPBITMAP (IPLUS CHAROFFSET BWIDTH)
                      (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      (ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWIDTH)))
                      CHEIGHT)                               (* ; 
                                             "Copy that portion to the right of the new character.")
               )
              ((OR (IGREATERP BASCENT CASCENT)
                   (IGREATERP BDESCENT CDESCENT))

               (* ;; "The new character is TALLER than the existing bitmap.  Make a larger bitmap.")

               (SETQ TEMPBITMAP (BITMAPCREATE OFWIDTH NHEIGHT BITSPERPIXEL))
               (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      OFWIDTH CHEIGHT)

               (* ;; "Copy the existing bitmap into it, adjusting for a larger descent in the new character (if there is one)")

               ))

     (* ;; "copy the new bitmap in and update parameters.")

           (BITBLT NEWCHARBITMAP 0 0 (OR TEMPBITMAP FONTBITMAP)
                  CHAROFFSET
                  (IMAX 0 (IDIFFERENCE NDESCENT BDESCENT))
                  BWIDTH BHEIGHT)
           [COND
              (TEMPBITMAP (UNINTERRUPTABLY
                              
                              (* ;; "update the parameters for this character set.")

                              (\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE)
                                     BWIDTH)                 (* ; 
                                                           "The new character's correct width")
                                                             (* ; 
                                                        "Make sure that we update imagewidths also")
                              (if IMWIDTHS
                                  then (\FSETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE)
                                                  BWIDTH))
                              (\FSETOFFSET OFFSETS (\CHAR8CODE CHARCODE)
                                     CHAROFFSET)
                              [COND
                                 (DW (for I from 0 to \MAXCHAR
                                        do               (* ; 
 "Run thru the offsets of later characters, adjusting them for the changed width of this character")
                                              (if (IGREATERP (\FGETOFFSET OFFSETS I)
                                                             CHAROFFSET)
                                                  then (\FSETOFFSET OFFSETS I
                                                                  (IPLUS DW (\FGETOFFSET OFFSETS I]
                              (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with 
                                                                                           TEMPBITMAP
                                     )
                              (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with 
                                                                                            NDESCENT)
                              (replace (CHARSETINFO CHARSETASCENT) of CSINFO with NASCENT
                                     )

                              (* ;; "update the properties for the font as a whole.")

                              [SETQ NASCENT (IMAX NASCENT (FONTPROP FONTDESC 'ASCENT]
                              [SETQ NDESCENT (IMAX NDESCENT (FONTPROP FONTDESC 'DESCENT]
                              (replace (FONTDESCRIPTOR \SFAscent) of FONTDESC with 
                                                                                            NASCENT)
                              (replace (FONTDESCRIPTOR \SFDescent) of FONTDESC with
                                                                                       NDESCENT)
                              (replace (FONTDESCRIPTOR \SFHeight) of FONTDESC
                                 with (IPLUS NDESCENT NASCENT)))]
           (RETURN NEWCHARBITMAP])

(MOVECHARBITMAP
  [LAMBDA (SRCECODE SRCEFONT DESTCODE DESTFONT CLIP)     (* ; "Edited 14-Dec-86 18:04 by Shih")

(* ;;; "moves a character from one font to another, clipping if necessary.")

    (PROG ((SRCEDESC (\GETFONTDESC SRCEFONT))
           (DESTDESC (\GETFONTDESC DESTFONT))
           SRCEASCENT SRCEDESCENT DESTASCENT DESTDESCENT CHARBITMAP TEMPBITMAP NEWASCENT NEWDESCENT)
          (SETQ CHARBITMAP (GETCHARBITMAP SRCECODE SRCEFONT))
          (SETQ SRCEASCENT (FONTPROP SRCEDESC 'ASCENT))
          (SETQ DESTASCENT (FONTPROP DESTDESC 'ASCENT))
          (SETQ SRCEDESCENT (FONTPROP SRCEDESC 'DESCENT))
          (SETQ DESTDESCENT (FONTPROP DESTDESC 'DESCENT))
          [SETQ NEWASCENT (COND
                             (CLIP DESTASCENT)
                             (T (IMAX SRCEASCENT DESTASCENT]
          [SETQ NEWDESCENT (COND
                              (CLIP DESTDESCENT)
                              (T (IMAX SRCEDESCENT DESTDESCENT]
          [COND
             ((OR (NEQ SRCEASCENT NEWASCENT)
                  (NEQ SRCEDESCENT NEWDESCENT))
              (SETQ TEMPBITMAP (BITMAPCREATE (BITMAPWIDTH CHARBITMAP)
                                      (IPLUS NEWASCENT NEWDESCENT)))
              (BITBLT CHARBITMAP 0 (IMAX 0 (IDIFFERENCE SRCEDESCENT NEWDESCENT))
                     TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NEWDESCENT SRCEDESCENT))
                     (BITMAPWIDTH CHARBITMAP)
                     (IMIN (IPLUS SRCEASCENT SRCEDESCENT)
                           (IPLUS NEWASCENT NEWDESCENT]
          (PUTCHARBITMAP DESTCODE DESTFONT (OR TEMPBITMAP CHARBITMAP)
                 NEWDESCENT])
)
(DEFINEQ

(FONTCOPY
  [LAMBDA FONTSPECS                                      (* ; "Edited 10-Nov-87 17:12 by FS")
                                                             (* ; 
                                            "makes a copy of a font changing the specified fields.")
    (PROG (NOERROR ERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT)

     (* ;; "Set NOERROR if we find it as a prop, but set ERROR if we find a PROP which is illegal.  Then just return NIL if NOERROR and ERROR, otherwise, call FONTCREATE.")

          [SETQ OLDFONT (\GETFONTDESC (ARG FONTSPECS 1)
                               (AND (type? FONTCLASS (ARG FONTSPECS 1))
                                    (COND
                                       ((AND (EQ FONTSPECS 2)
                                             (LISTP (ARG FONTSPECS 2)))
                                        (LISTGET (ARG FONTSPECS 2)
                                               'DEVICE))
                                       (T (for I from 2 by 2 to FONTSPECS
                                             do (COND
                                                       ((AND (NEQ I FONTSPECS)
                                                             (EQ (ARG FONTSPECS I)
                                                                 'DEVICE))
                                                        (RETURN (ARG FONTSPECS (ADD1 I]
          (SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of OLDFONT))
          (SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of OLDFONT))
          (SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT))
          (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of OLDFONT))
          (SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of OLDFONT))
          [for I VAL from 2 by 2 to FONTSPECS
             do [SETQ VAL (COND
                                 ((NOT (EQ I FONTSPECS))
                                  (ARG FONTSPECS (ADD1 I]
                   (SELECTQ (ARG FONTSPECS I)
                       (FAMILY (SETQ FAMILY VAL))
                       (SIZE (SETQ SIZE VAL))
                       (FACE (SETQ FACE (\FONTFACE VAL)))
                       (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL)))
                       (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL)))
                       (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL)))
                       (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL)))
                       (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL)))
                       (ROTATION (SETQ ROTATION VAL))
                       (DEVICE (SETQ DEVICE VAL))
                       (NOERROR (SETQ NOERROR VAL))
                       (COND
                          [(AND (EQ I 2)
                                (EQ FONTSPECS 2)
                                (LISTP (ARG FONTSPECS 2)))
                           (for J on (ARG FONTSPECS 2) by (CDDR J)
                              do (SETQ VAL (CADR J))
                                    (SELECTQ (CAR J)
                                        (FAMILY (SETQ FAMILY VAL))
                                        (SIZE (SETQ SIZE VAL))
                                        (FACE (SETQ FACE (\FONTFACE VAL)))
                                        (WEIGHT (SETQ FACE (create FONTFACE
                                                              using FACE WEIGHT _ VAL)))
                                        (SLOPE (SETQ FACE (create FONTFACE
                                                             using FACE SLOPE _ VAL)))
                                        (EXPANSION (SETQ FACE (create FONTFACE
                                                                 using FACE EXPANSION _ VAL)))
                                        (BACKCOLOR (SETQ FACE (create FONTFACE
                                                                 using FACE BACKCOLOR _ VAL)))
                                        (FORECOLOR (SETQ FACE (create FONTFACE
                                                                 using FACE FORECOLOR _ VAL)))
                                        (ROTATION (SETQ ROTATION VAL))
                                        (DEVICE (SETQ DEVICE VAL))
                                        (NOERROR (SETQ NOERROR VAL))
                                        (COND
                                           (NOERROR 

                                                  (* ;; 
  "Fell through the SELECTQ, so an illegal PROP.  But, if NOERROR, just note the error, otherwise ")

                                                  (SETQ ERROR T))
                                           (T (\ILLEGAL.ARG (CAR J]
                          (T (if NOERROR
                                 then (SETQ ERROR T)
                               else (\ILLEGAL.ARG (ARG FONTSPECS I]
          (RETURN (if (AND NOERROR ERROR)
                      then NIL
                    else (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR])

(FONTSAVAILABLE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?)
                                                             (* rrb " 7-Nov-84 15:41")

(* ;;; "returns a list of the fonts fitting a description that are available.  FAMILY SIZE FACE or ROTATION can be * which means get them all.  if LOADEDONLYFLG is non-NIL, only fonts in core will be considered.")

    (DECLARE (GLOBALVARS IMAGESTREAMTYPES))
    (PROG (FONTX DEV)
          [SETQ DEV (COND
                       ((type? STREAM DEVICE)
                        (COND
                           ((LISTP (SETQ DEV (IMAGESTREAMTYPE DEVICE)))
                            (CAR DEV))
                           (T DEV)))
                       (DEVICE)
                       (T 'DISPLAY]
          (RETURN
           (COND
              ((LISTP FAMILY)
               (COND
                  ((EQ (CAR FAMILY)
                       'FONT)
                   (SETQ FONTX (CDR FAMILY)))
                  (T (SETQ FONTX FAMILY)))
               (FONTSAVAILABLE (CAR FONTX)
                      (OR (CADR FONTX)
                          SIZE)
                      (OR (CADDR FONTX)
                          FACE)
                      (OR (CADDDR FONTX)
                          ROTATION)
                      DEV CHECKFILESTOO?))
              ([SETQ FONTX (COND
                              ((type? FONTDESCRIPTOR FAMILY)
                               FAMILY)
                              ((NULL FAMILY)
                               (DEFAULTFONT DEV))
                              ((type? FONTCLASS FAMILY)

                               (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.  Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.")
                                                             (* ; 
                                                       "I don't know what to do in this case- rrb.")
                               (\COERCEFONTDESC FAMILY DEV T))
                              ((OR (IMAGESTREAMP FAMILY)
                                   (type? WINDOW FAMILY))
                               (DSPFONT NIL FAMILY]          (* ; 
                 "FAMILY was a spec for a font descriptor, use it and extend it by the other args.")
               (FONTSAVAILABLE (FONTPROP FONTX 'FAMILY)
                      (OR SIZE (FONTPROP FONTX 'SIZE))
                      (OR FACE (FONTPROP FONTX 'FACE))
                      (OR ROTATION (FONTPROP FONTX 'ROTATION))
                      (OR DEVICE (FONTPROP FONTX 'DEVICE))
                      CHECKFILESTOO?))
              (T (PROG ((FONTFACE FACE))
                   RETRY
                       (OR (LITATOM FAMILY)
                           (LISPERROR "ARG NOT LITATOM" FAMILY T))
                       (OR (AND (FIXP SIZE)
                                (IGREATERP SIZE 0))
                           (EQ SIZE '*)
                           (\ILLEGAL.ARG SIZE))
                       [OR (EQ FONTFACE '*)
                           (SETQ FONTFACE (OR (\FONTFACE FACE T)
                                              (RETURN NIL]
                       (OR (U-CASEP FAMILY)
                           (SETQ FAMILY (U-CASE FAMILY)))
                       (COND
                          ((NULL ROTATION)
                           (SETQ ROTATION 0))
                          ((AND (FIXP ROTATION)
                                (IGEQ ROTATION 0)))
                          ((EQ ROTATION '*))
                          (T (\ILLEGAL.ARG ROTATION)))
                       (RETURN (UNION (\LOOKUPFONTSINCORE FAMILY SIZE FONTFACE ROTATION DEV)
                                      (COND
                                         ((NOT CHECKFILESTOO?)
                                          NIL)
                                         [(EQ DEV '*)        (* ; "map thru all the devices.")
                                          (for EXTANTDEV in IMAGESTREAMTYPES
                                             join (APPLY* (OR (CADR (ASSOC 'FONTSAVAILABLE
                                                                               (CDR EXTANTDEV)))
                                                                  (FUNCTION NILL))
                                                             FAMILY SIZE FONTFACE ROTATION
                                                             (CAR EXTANTDEV]
                                         (T                  (* ; 
                                                           "apply the device font lookup function.")
                                            (APPLY* (OR [CADR (ASSOC 'FONTSAVAILABLE
                                                                     (CDR (ASSOC DEV IMAGESTREAMTYPES
                                                                                 ]
                                                        (FUNCTION NILL))
                                                   FAMILY SIZE FONTFACE ROTATION DEV])

(FONTFILEFORMAT
  [LAMBDA (STRM LEAVEOPEN)                               (* rmk%: "11-Sep-84 17:16")
                                                             (* ; "Returns the font format of STRM")
    [OR (OPENP STRM 'INPUT)
        (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD]
    (PROG1 (SELECTC (\WIN STRM)
               ((LIST (LLSH 1 15)
                      (LOGOR (LLSH 1 15)
                             (LLSH 1 13))) 

                                 (* ;; "If high bit of type is on, then must be strike.  If 2nd bit is on, must be strike-index, and we punt.  We don't care about the 3rd bit")

                    
                    (* ;; "first word has high bits (onebit index fixed).  Onebit means 'new-style font' , index is 0 for simple strike, 1 for index, and fixed is if all chars have max width.  Lisp doesn't care about 'fixed'")

                    'STRIKE)
               ((LOGOR (LLSH 16 8)
                       12) 
                           (* ;; "This is the length of a standard index header.  Other files could also have this value, but it's a pretty good discriminator")

                    
                    (* ;; "Skip to byte 25;  do it with BINS so works for non-randaccessp devices.  This skips the standard name header, then look for type 3 in the following header")

                    (FRPTQ 22 (\BIN STRM))                   (* ; "(SETFILEPTR STRM 25)")
                    (AND (EQ 3 (LRSH (\BIN STRM)
                                     4))
                         'AC))
               NIL)
        (OR LEAVEOPEN (CLOSEF STRM)))])

(FONTP
  [LAMBDA (X)                                            (* rmk%: "13-Sep-84 09:04")
                                                             (* ; "is X a FONTDESCRIPTOR?")
    (COND
       ((OR (type? FONTDESCRIPTOR X)
            (type? FONTCLASS X))
        X])

(FONTUNPARSE
  [LAMBDA (FONT)                                         (* kbr%: "25-Feb-86 19:40")

    (* ;; "Produces a minimal specification of the font or fontclass specification, for dumping by Tedit, imageobjects.")

    (PROG (FACE SPEC)
          (SETQ SPEC (COND
                        ((type? FONTDESCRIPTOR FONT)
                         (FONTPROP FONT 'SPEC))
                        [(type? FONTCLASS FONT)
                         (RETURN (CONS 'CLASS (FONTCLASSUNPARSE FONT]
                        (T 
                           (* ;; "Could be a non-instantiated specification in a fontclass, just use it as the spec without creating the font.")

                           FONT)))
          (OR SPEC (RETURN))
          (SETQ FACE (CADDR SPEC))                           (* ; 
                        "FACE and rotation can be NIL for a non-fontdescriptor fontclass component")
          [SETQ FACE (COND
                        ([OR (NULL FACE)
                             (EQUAL FACE '(MEDIUM REGULAR REGULAR]
                         NIL)
                        ((LITATOM FACE)
                         FACE)
                        [(LISTP FACE)
                         (PACK (LIST* (NTHCHAR (fetch (FONTFACE WEIGHT) of FACE)
                                             1)
                                      (NTHCHAR (fetch (FONTFACE SLOPE) of FACE)
                                             1)
                                      (NTHCHAR (fetch (FONTFACE EXPANSION) of FACE)
                                             1)
                                      (COND
                                         ((fetch (FONTFACE COLOR) of FACE)
                                          (LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE)
                                                "-"
                                                (fetch (FONTFACE FORECOLOR) of FACE]
                        (T (SHOULDNT]                        (* ; 
                                                    "Don't return device, or any trailing defaults")
          (RETURN (CONS (CAR SPEC)
                        (CONS (CADR SPEC)
                              (COND
                                 ([AND (CADDDR SPEC)
                                       (NOT (EQ 0 (CADDDR SPEC]
                                  (LIST (OR FACE 'MRR)
                                        (CADDDR SPEC)))
                                 (FACE (CONS FACE])

(SETFONTDESCRIPTOR
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT)        (* ; "Edited  1-Aug-88 16:16 by rmk:")
                                                             (* ; "Edited  5-Mar-87 19:28 by FS")

    (* ;; "saves a font descriptor under a family/size/face/rotation/device key so that it will be retreived by FONTCREATE.  This is a user entry.")

    (DECLARE (GLOBALVARS \FONTSINCORE))
    (SETQ DEVICE (\DEVICESYMBOL DEVICE))                 (* ; "Unpackageify")
    (AND FONT (SETQ FONT (\COERCEFONTDESC FONT DEVICE))) (* ; 
                            "NIL is used to clobber existing font so that next use will reread it.")
    (SETQ FAMILY (\FONTSYMBOL FAMILY))                   (* ; "Unpackageify")
    (SETQ FACE (\FONTFACE FACE NIL DEVICE))
    (OR ROTATION (SETQ ROTATION 0))
    (OR (AND (FIXP SIZE)
             (IGEQ SIZE 0))
        (\ILLEGAL.ARG SIZE))
    (PROG [(X (OR (FASSOC FAMILY \FONTSINCORE)
                  (CAR (push \FONTSINCORE (LIST FAMILY]
          [SETQ X (OR (FASSOC SIZE (CDR X))
                      (CAR (push (CDR X)
                                  (LIST SIZE]
          [SETQ X (OR (SASSOC FACE (CDR X))
                      (CAR (push (CDR X)
                                  (LIST FACE]                (* ; "SASSOC cause FACE is listp")
          [SETQ X (OR (FASSOC ROTATION (CDR X))
                      (CAR (push (CDR X)
                                  (LIST ROTATION]
          [SETQ X (OR (FASSOC DEVICE (CDR X))
                      (CAR (push (CDR X)
                                  (LIST DEVICE]
          (RPLACD X FONT)
          (RETURN FONT])

(CHARCODEP
  [LAMBDA (CHCODE)                                       (* gbn "22-Jul-85 16:35")
                                                             (* ; 
                                                           "is CHCODE a legal character code?")
    (AND (SMALLP CHCODE)
         (IGEQ CHCODE 0)
         (ILEQ CHCODE \MAXNSCHAR])

(EDITCHAR
  [LAMBDA (CHARCODE FONT)                                (* rrb "24-MAR-82 12:22")
                                                             (* ; 
                                                 "calls the bitmap editor on a character of a font")
    (PROG ((FONTDESC (\GETFONTDESC FONT)))
          (RETURN (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC])

(\STREAMCHARWIDTH
  [LAMBDA (CHARCODE STREAM TTBL)                         (* JonL " 8-NOV-83 03:31")

    (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for the various escape sequences.  Used by \ECHOCHAR")

    (SETQ CHARCODE (LOGAND CHARCODE \CHARMASK))
    ((LAMBDA (WIDTHSVECTOR)

       (* ;; "Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean that the character's glyph simply isn't loaded;  e.g., it may want #^A")

       (SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM)
                                   (SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM))
                                   (ffetch DDWIDTHSCACHE of WIDTHSVECTOR))
                              \UNITWIDTHSVECTOR))
       (SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA)
                                                      of (OR (TERMTABLEP TTBL)
                                                                 \PRIMTERMTABLE))
                                                CHARCODE))
           (INDICATE.CCE ([LAMBDA (CC)
                            (IPLUS (if (IGEQ CHARCODE (CHARCODE %#^@))
                                       then              (* ; 
                                          "A META charcode -- implies that the 8th bit is non-zero")
                                             (SETQ CC (LOADBYTE CHARCODE 0 7))
                                             (\FGETWIDTH WIDTHSVECTOR (CHARCODE %#))
                                     else 0)
                                   (if (ILESSP CC (CHARCODE SPACE))
                                       then              (* ; "A CONTROL charcode")
                                             (add CC (CONSTANT (LLSH 1 6)))
                                             (\FGETWIDTH WIDTHSVECTOR (CHARCODE ^))
                                     else 0)
                                   (\FGETWIDTH WIDTHSVECTOR CC]
                          CHARCODE))
           (SIMULATE.CCE (SELCHARQ CHARCODE
                              ((EOL CR LF BELL) 
                                   NIL)
                              (ESCAPE (\FGETWIDTH WIDTHSVECTOR (CHARCODE $)))
                              (TAB (PROG ((SPACEWIDTH (\FGETWIDTH WIDTHSVECTOR (CHARCODE SPACE)))
                                          (NEWXPOSITON (DSPXPOSITION NIL STREAM))
                                          TABWIDTH)
                                         (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
                                         [add NEWXPOSITON (SETQ TABWIDTH
                                                               (IDIFFERENCE
                                                                TABWIDTH
                                                                (IMOD (IDIFFERENCE NEWXPOSITON
                                                                             (DSPLEFTMARGIN NIL 
                                                                                    STREAM))
                                                                      TABWIDTH]
                                         (RETURN (if (IGREATERP NEWXPOSITON (DSPRIGHTMARGIN
                                                                                 NIL STREAM))
                                                     then 
                                                             (* ; 
                                                           "tab was past rightmargin, force cr.")
                                                           NIL
                                                   else TABWIDTH))))
                              (\FGETWIDTH WIDTHSVECTOR CHARCODE)))
           (REAL.CCE (SELECTC CHARCODE
                         ((CHARCODE (EOL CR LF)) 
                              NIL)
                         (ERASECHARCODE NIL)
                         (\FGETWIDTH WIDTHSVECTOR CHARCODE)))
           (IGNORE.CCE 0)
           (SHOULDNT])

(\UNITWIDTHSVECTOR
  [LAMBDA NIL                                            (* JonL " 7-NOV-83 19:23")
    (SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXCHAR 3)
                                                WORDSPERCELL)))
    (for I from 0 to (IPLUS \MAXCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1))
    \UNITWIDTHSVECTOR])

(\CREATEDISPLAYFONT
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)     (* gbn%: "25-Jan-86 18:02")
    (PROG [(FONTDESC (create FONTDESCRIPTOR
                            FONTDEVICE _ DEVICE
                            FONTFAMILY _ FAMILY
                            FONTSIZE _ SIZE
                            FONTFACE _ FACE
                            \SFAscent _ 0
                            \SFDescent _ 0
                            \SFHeight _ 0
                            ROTATION _ ROTATION
                            FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE]
          (RETURN (COND
                     ((\GETCHARSETINFO CHARSET FONTDESC T)
                      FONTDESC)
                     (T NIL])

(\CREATECHARSET.DISPLAY
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
                                                             (* ; "Edited 14-Jan-88 23:42 by FS")

    (* ;; "Color Stuff removed  -FS.")

    (* ;; "Replace Cond below with")

    (* ;; "(PROG (XCSINFO)")

    (* ;; "(SETQ XCSINFO &)")

    (* ;; "(COND ((FMEMB DEVICE \\COLORDISPLAYSTREAMTYPES) (SETQ XCSINFO (\\SFMAKECOLOR XCSINFO (OR (|fetch| (FONTFACE BACKCOLOR) |of| FACE) 0) (OR (|fetch| (FONTFACE FORECOLOR) |of| FACE) (MAXIMUMCOLOR (\\DISPLAYSTREAMTYPEBPP DEVICE))) (\\DISPLAYSTREAMTYPEBPP DEVICE)))))")

    (* ;; "(RETURN XCSINFO)))")

(* ;;; "tries to build the csinfo required for CHARSET.  Does the necessary coercions.")

(* ;;; 
"NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")

    (DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS))

    (* ;; "DISPLAYFONTCOERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...).  Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a similar list.")

    (COND
       ((PROG1 (for TRANSL in DISPLAYFONTCOERCIONS bind NEWCSINFO UFONT REALFONT
                  when (AND (SETQ UFONT (CAR TRANSL))
                                (EQ FAMILY (CAR UFONT))
                                (OR (NOT (CADR UFONT))
                                    (EQ SIZE (CADR UFONT)))
                                (OR (NOT (CADDR UFONT))
                                    (EQ CHARSET (CADDR UFONT)))
                                (SETQ REALFONT (CADR TRANSL))
                                (SETQ NEWCSINFO (\CREATECHARSET.DISPLAY (OR (CAR REALFONT)
                                                                                FAMILY)
                                                       (OR (CADR REALFONT)
                                                           SIZE)
                                                       FACE ROTATION DEVICE (OR (CADDR REALFONT)
                                                                                CHARSET)
                                                       FONTDESC NOSLUG?))) do (RETURN NEWCSINFO))
                                                             (* ; 
                        "Just recursively call ourselves to handle entries in DISPLAYFONTCOERCIONS")
               ))
       (T 
          (* ;; "One weirdness is, if you have a coercion, and the real-font is missing, you can't get a missingfont coercion on the user-font because the real-font missingfont coercion shadows it out.")

          (\CREATE-REAL-CHARSET.DISPLAY FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?
                 ])

(\CREATE-REAL-CHARSET.DISPLAY
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
                                                             (* ; "Edited 15-Jan-88 00:02 by FS")
    (COND
       [(AND (EQ ROTATION 0)
             (PROG1 (\READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION 'DISPLAY CHARSET)
                                                             (* ; 
 "If it is available, this will force the appropriate file to be read to fill in the charset entry")
                    ]
       (T 
          (* ;; "if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised 'by hand'.  Past that point, we do not allow DISPLAYFONTCOERCIONS, only MISSINGxxxxDISPLAYFONTCOERCIONS.")

          (PROG (NEWFONT XFONT XLATEDFAM CSINFO)
                (RETURN (COND
                           [(NEQ ROTATION 0)

                            (* ;; "to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.  If its still missing, then search for missing display font coercions (e.g. no avail. charset, *but*, do not recurse (avoid getting into infinite loops).  This allows partial permutations of fonts.")

                            (OR (MEMB ROTATION '(90 270))
                                (ERROR "only implemented rotations are 0, 90 and 270." ROTATION))
                            (COND
                               ((SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE FACE 0 'DISPLAY 
                                                   CHARSET))

                                (* ;; "Do not call FONTCREATE here.  The user might have modified (via PUTCHARBITMAP, etc.) the in-memory version of the source.  This also fixes a bug in which several font descriptors ended up sharing bitmaps or charsetvectors, causing havoc when the user modifies either fontdescriptor.")

                                (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
                                    then (\SFROTATECSINFO CSINFO ROTATION)
                                  else NIL]
                           ((AND (EQ (fetch WEIGHT of FACE)
                                     'BOLD)
                                 (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE
                                                    (create FONTFACE using FACE WEIGHT _
                                                                               'MEDIUM)
                                                    0
                                                    'DISPLAY CHARSET)))

                            (* ;; "if we want a bold font, and the medium weight font is available, build the medium weight version then call \SFMAKEBOLD on the csinfo")

                            (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
                                then (\SFMAKEBOLD CSINFO)
                              else NIL))
                           ((AND (EQ (fetch (FONTFACE SLOPE) of FACE)
                                     'ITALIC)
                                 (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE
                                                    (create FONTFACE using FACE SLOPE _
                                                                               'REGULAR)
                                                    0
                                                    'DISPLAY CHARSET)))
                            (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
                                then (\SFMAKEITALIC CSINFO)
                              else NIL))
                           [(AND CHARSET (NOT (EQL 0))
                                 (for TRANSL in MISSINGCHARSETDISPLAYFONTCOERCIONS
                                    bind NEWCSINFO UFONT REALFONT
                                    when (AND (SETQ UFONT (CAR TRANSL))
                                                  (EQ FAMILY (CAR UFONT))
                                                  (OR (NOT (CADR UFONT))
                                                      (EQ SIZE (CADR UFONT)))
                                                  (OR (NOT (CADDR UFONT))
                                                      (EQ CHARSET (CADDR UFONT)))
                                                  (SETQ REALFONT (CADR TRANSL))
                                                  (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY
                                                                   (OR (CAR REALFONT)
                                                                       FAMILY)
                                                                   (OR (CADR REALFONT)
                                                                       SIZE)
                                                                   FACE ROTATION DEVICE
                                                                   (OR (CADDR REALFONT)
                                                                       CHARSET)
                                                                   FONTDESC NOSLUG?)))
                                    do (RETURN NEWCSINFO]
                           ((for TRANSL in MISSINGDISPLAYFONTCOERCIONS bind NEWCSINFO 
                                                                                     UFONT REALFONT
                               when (AND (SETQ UFONT (CAR TRANSL))
                                             (EQ FAMILY (CAR UFONT))
                                             (OR (NOT (CADR UFONT))
                                                 (EQ SIZE (CADR UFONT)))
                                             (OR (NOT (CADDR UFONT))
                                                 (EQ CHARSET (CADDR UFONT)))
                                             (SETQ REALFONT (CADR TRANSL))
                                             (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY
                                                              (OR (CAR REALFONT)
                                                                  FAMILY)
                                                              (OR (CADR REALFONT)
                                                                  SIZE)
                                                              FACE ROTATION DEVICE
                                                              (OR (CADDR REALFONT)
                                                                  CHARSET)
                                                              FONTDESC NOSLUG?)))
                               do (RETURN NEWCSINFO)))
                           ((NOT NOSLUG?)
                            (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
                                                     of FONTDESC)
                                   (FONTPROP FONTDESC 'ASCENT)
                                   (FONTPROP FONTDESC 'DESCENT)
                                   (FONTPROP FONTDESC 'DEVICE])

(\BUILDSLUGCSINFO
  [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE)            (* ; "Edited  9-May-93 23:12 by rmk:")

(* ;;; "builds a csinfo which contains only the slug (black rectangle) character.  Called only for display.")

    (SETQ SCALE (OR SCALE 1))
    (PROG ((CSINFO (create CHARSETINFO
                          CHARSETASCENT _ ASCENT
                          CHARSETDESCENT _ DESCENT))
           WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
          (REPLACE IMAGEWIDTHS OF CSINFO WITH WIDTHS)
          (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (
                                                                                 \CREATECSINFOELEMENT
                                                                                   )))
          (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
          [replace (CHARSETINFO CHARSETBITMAP) of CSINFO
             with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE))
                                          (ROUND (QUOTIENT (IPLUS ASCENT DESCENT)
                                                        SCALE]
          [BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE]
          (RETURN CSINFO])

(\SEARCHDISPLAYFONTFILES
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)             (* ; "Edited  5-Mar-87 18:55 by FS")

    (* ;; "     This function called via APPLY in IMAGESTREAMTYPES.")

    (* ;; "     Returns a list of the fonts that can be read in for displaylike devices.  Rotation is ignored because it is assumed that all devices support 0 90 and 270.")

    (* ;; "     Note we *allow* a device that is not 'DISPLAY for guys like 4DISPLAY, 8DISPLAY, 24DISPLAY, and also possibly for FX80,  etc. (guys that want DISPLAYFONTS anyway).  Should have some hook though for FONTEXTENSIONS, FONTDIRECTORIES??")

    (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
    (SELECTQ (SYSTEMTYPE)
        (D (\SEARCHFONTFILES FAMILY SIZE FACE ROTATION DEVICE DISPLAYFONTDIRECTORIES 
                  DISPLAYFONTEXTENSIONS))
        (J                                                   (* OLD J code from \READDISPLAYFONT
                                                           (PROG ((FONTFILE (\FONTFILENAME 
                                                           FAMILY SIZE FACE)) FONTDESC STRM)
                                                           (COND ((SETQ STRM (AND 
                                                           FONTDIRECTORIES (FINDFILE FONTFILE T 
                                                           FONTDIRECTORIES)))
                                                           (SETQ STRM (OPENSTREAM FONTFILE
                                                           (QUOTE INPUT))) (SETQ FONTDESC
                                                           (\READJERICHOFONTFILE FAMILY SIZE 
                                                           FACE STRM)) (CLOSEF STRM)))
                                                           (RETURN FONTDESC)))
           NIL)
        (SHOULDNT])

(\SEARCHFONTFILES
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST)   (* ; "Edited 14-Sep-96 10:54 by rmk:")
                                                             (* ; "Edited  6-Oct-89 12:34 by bvm")

    (* ;; "GENERIC FUNCTION")

    (* ;; "returns a list of the fonts that can be read in for a device.  Rotation is ignored because it is assumed that all devices support 0 90 and 270.")

    (SETQ FAMILY (\FONTSYMBOL FAMILY))
    (SETQ DEVICE (\FONTSYMBOL DEVICE))
    (SETQ FACE (\FONTFACE FACE))
    (BIND (FILING.ENUEMRATION.DEPTH _ 1)
           FONTSFOUND THISFONT THISFACE FOR E INSIDE EXTLST
       DO [FOR DIR INSIDE DIRLST
                 BIND (FILEPATTERN _ (IF (FMEMB E *OLD-FONT-EXTENSIONS*)
                                             THEN (\FONTFILENAME.OLD FAMILY SIZE FACE E)
                                           ELSE (\FONTFILENAME FAMILY SIZE FACE E)))
                 DO 

                       (* ;; "Hack above to handle both old and new font file names.  The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup.  If set to a list of extensions, just those will be looked up with old-style  conventions")

                       (FOR FONTFILE IN (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR
                                                                  'BODY FILEPATTERN))
                          WHEN [PROGN (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE DEVICE))
                                          (SETQ THISFACE (CADDR THISFONT))

                                          (* ;; 
                                        "make sure the face, size, and family really match.")

                                          (AND (NOT (MEMBER THISFONT FONTSFOUND))
                                               (OR (EQ FAMILY '*)
                                                   (EQ FAMILY (CAR THISFONT)))
                                               (OR (EQ SIZE '*)
                                                   (EQ SIZE (CADR THISFONT)))
                                               (OR (EQ FACE '*)
                                                   (EQUAL FACE THISFACE)
                                                   (AND (OR (EQ (CAR FACE)
                                                                '*)
                                                            (EQ (CAR FACE)
                                                                (CAR THISFACE)))
                                                        (OR (EQ (CADR FACE)
                                                                '*)
                                                            (EQ (CADR FACE)
                                                                (CADR THISFACE)))
                                                        (OR (EQ (CADDR FACE)
                                                                '*)
                                                            (EQ (CADDR FACE)
                                                                (CADDR THISFACE]
                          DO (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
       FINALLY (RETURN FONTSFOUND])

(\FINDFONTFILE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST)
                                                             (* ; "Edited 14-Sep-96 10:53 by rmk:")
                                                             (* ; "Edited  6-Oct-89 11:18 by bvm")

    (* ;; "Find any font file on any directory with any naming convention with any extension.  Note that ROTATION and DEVICE are just place holders.   DEVICE is irrelevant because DIRLST already incorporates the device information.  The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup.  If set to a list of extensions, just those will be looked up with old-style conventions.")

    (BIND FONTFILE FOR EXT INSIDE EXTLST
       WHEN (SETQ FONTFILE (FINDFILE (IF (FMEMB EXT *OLD-FONT-EXTENSIONS*)
                                             THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT 
                                                             CHARSET)
                                           ELSE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET))
                                      T DIRLST)) DO (RETURN FONTFILE])

(\FONTSYMBOL
  [LAMBDA (X ElseReturnXFlg)                             (* ; "Edited 28-Jul-88 11:59 by rmk:")
                                                             (* ; "Edited 24-Mar-87 14:32 by FS")

    (* ;; "Return a symbol in IL package and is in uppercase.  Currently the function IL:U-CASE is believed to do this, but if it changes, this is the font hook.  ElseReturnXFlg is if you want an IL symbol if X is a symbol or string, otherwise just X.")

    (COND
       ((LITATOM X)
        (U-CASE X))
       ((STRINGP X)
        (MKATOM (U-CASE X)))
       (ElseReturnXFlg X)
       (T (ERROR "Want an IL symbol"])

(\DEVICESYMBOL
  [LAMBDA (X ElseReturnXFlg)                             (* ; "Edited  7-Oct-88 20:07 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:43 by rmk:")
                                                             (* ; "Edited 24-Mar-87 14:33 by FS")

    (* ;; "Return a canonicalized atom good for comparing with DEVICE symbols")

    (LET ((STRM (\GETSTREAM X 'OUTPUT T)))
         (COND
            (STRM (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of
                                                                                         STRM)))
            ((NULL X)
             'DISPLAY)
            (T                                               (* ; "because its used in ASSOC.")
               (\FONTSYMBOL X ElseReturnXFlg])

(\FONTFACE
  [LAMBDA (FACE NOERRORFLG DEV)                          (* ; "Edited  1-Aug-88 09:44 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:50 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:49 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:41 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:38 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")
                                                             (* ; "Edited 25-Feb-87 22:58 by FS")

    (* ;; "Coerces FACE into standard FONTFACE record, usually returns a CONSTANT (so you'd better not RPLACD or REPLACE fields!!)")

    (PROG (UNKNOWN (WEIGHT 'MEDIUM)
                 (SLOPE 'REGULAR)
                 (EXPANSION 'REGULAR)
                 (OLDFACE FACE))

     (* ;; "On error, can signal, or return NIL, or return REGULAR face.")

          [SETQ UNKNOWN (COND
                           ((EQ NOERRORFLG 'REGULAR)
                            'REGULAR)
                           (T 'ERROR]
          [COND
             ((type? FONTFACE FACE)

              (* ;; "List Case.  Unpack because want to validate fields")

              (SETQ WEIGHT (fetch (FONTFACE WEIGHT) of FACE))
              (SETQ SLOPE (fetch (FONTFACE SLOPE) of FACE))
              (SETQ EXPANSION (fetch (FONTFACE EXPANSION) of FACE))

              (* ;; "Handle unknown faces")

              [OR (\FONT.SYMBOLMEMB WEIGHT '             (* BOLD MEDIUM LIGHT))
                  (SETQ WEIGHT (COND
                                  ((\FONT.COMPARESYMBOL WEIGHT 'REGULAR)

                                   (* ;; "Clean up WEIGHT REGULAR vs. MEDIUM")

                                   (SETQ WEIGHT 'MEDIUM))
                                  (T UNKNOWN]
              (OR (\FONT.SYMBOLMEMB SLOPE '              (* REGULAR ITALIC))
                  (SETQ SLOPE UNKNOWN))
              (OR (\FONT.SYMBOLMEMB EXPANSION '          (* COMPRESSED REGULAR EXPANDED))
                  (SETQ EXPANSION UNKNOWN)))
             ((OR (LITATOM FACE)
                  (STRINGP FACE))
              (COND
                 ((NULL FACE)                                (* ; "Fast vanilla default")
                  )
                 ((EQ (NCHARS FACE)
                      3)                                     (* ; "3 char notation case")
                  (SETQ WEIGHT (SELCHARQ (CHCON1 FACE)
                                    ((B b) 
                                         'BOLD)
                                    ((M m R r) 
                                         'MEDIUM)
                                    ((L l) 
                                         'LIGHT)
                                    UNKNOWN))
                  (SETQ SLOPE (SELCHARQ (NTHCHARCODE FACE 2)
                                   ((R r) 
                                        'REGULAR)
                                   ((I i) 
                                        'ITALIC)
                                   UNKNOWN))
                  (SETQ EXPANSION (SELCHARQ (NTHCHARCODE FACE 3)
                                       ((R r) 
                                            'REGULAR)
                                       ((C c) 
                                            'COMPRESSED)
                                       ((E e) 
                                            'EXPANDED)
                                       UNKNOWN)))
                 ((SELECTQ FACE
                      (BOLD (SETQ WEIGHT 'BOLD))
                      (ITALIC (SETQ SLOPE 'ITALIC))
                      (BOLDITALIC (SETQ WEIGHT 'BOLD)
                                  (SETQ SLOPE 'ITALIC))
                      ((STANDARD REGULAR) 
                           T)
                      NIL))
                 ((\FONT.COMPARESYMBOL FACE 'BOLD)
                  (SETQ WEIGHT 'BOLD))
                 ((\FONT.COMPARESYMBOL FACE 'ITALIC)
                  (SETQ SLOPE 'ITALIC))
                 ((\FONT.COMPARESYMBOL FACE 'BOLDITALIC)
                  (SETQ WEIGHT 'BOLD)
                  (SETQ SLOPE 'ITALIC))
                 ((\FONT.SYMBOLMEMB FACE '(STANDARD REGULAR NIL NNN))
                                                             (* ; "Vanilla case")
                  )
                 ((STRPOS "-" FACE)                          (* ; "Color fontface spec!")
                  (SETQ FACE (\FONTFACE.COLOR FACE NOERRORFLG DEV))
                  (RETURN FACE))
                 ((\FONT.SYMBOLMEMB FACE '               (* ***))
                                                             (* ; "Wildcard case")
                  (SETQ WEIGHT '*)
                  (SETQ SLOPE '*)
                  (SETQ EXPANSION '*))
                 (T                                          (* ; "Other litatom error case")
                    (SETQ WEIGHT UNKNOWN)
                    (SETQ SLOPE UNKNOWN)
                    (SETQ EXPANSION UNKNOWN]
          (if (OR (EQ WEIGHT 'ERROR)
                      (EQ SLOPE 'ERROR)
                      (EQ EXPANSION 'ERROR))
              then (if NOERRORFLG
                           then (RETURN NIL)
                         else (\ILLEGAL.ARG OLDFACE)))

     (* ;; "Avoid consing by returning constant faces (historical:  really, would have been better to return MRR, but users have know about this for too long (rmk))")

          (RETURN (COND
                     ((AND (EQ WEIGHT 'MEDIUM)
                           (EQ SLOPE 'REGULAR)
                           (EQ EXPANSION 'REGULAR))          (* ; "MRR")
                      (CONSTANT (create FONTFACE)))
                     [(AND (EQ WEIGHT 'BOLD)
                           (EQ SLOPE 'REGULAR)
                           (EQ EXPANSION 'REGULAR))          (* ; "BRR")
                      (CONSTANT (create FONTFACE
                                       WEIGHT _ 'BOLD]
                     [(AND (EQ WEIGHT 'MEDIUM)
                           (EQ SLOPE 'ITALIC)
                           (EQ EXPANSION 'REGULAR))          (* ; "MIR")
                      (CONSTANT (create FONTFACE
                                       SLOPE _ 'ITALIC]
                     [(AND (EQ WEIGHT 'BOLD)
                           (EQ SLOPE 'ITALIC)
                           (EQ EXPANSION 'REGULAR))          (* ; "BIR")
                      (CONSTANT (create FONTFACE
                                       WEIGHT _ 'BOLD
                                       SLOPE _ 'ITALIC]
                     (T                                      (* ; "Otherwise, cons up")
                        (create FONTFACE
                               WEIGHT _ WEIGHT
                               SLOPE _ SLOPE
                               EXPANSION _ EXPANSION])

(\FONTFACE.COLOR
  [LAMBDA (FACE NOERRORFLG DEV)                          (* ; "Edited 28-Jul-88 14:51 by rmk:")
                                                             (* ; "Edited 28-Jul-88 13:09 by rmk:")
                                                             (* ; "Edited 24-Mar-87 17:03 by FS")

    (* ;; "This used to be \FONTFACE.  Renamed \FONTFACE.COLOR, and \FONTFACE rewritten.  The section below should also be redone")

    (* ;; "Takes a variety of user specifications and converts them to a standard FONTFACE record.")

    (* ;; "b/w fontfaces are extended by an optional '-backcolor-forecolor'")

    (* ;; "the atom NNN is interpreted the same as NIL or MRR to cover up a bug described in AR 3025, the FONTNNN bug")

    (DECLARE (GLOBALVARS \COLORDISPLAYSTREAMTYPES))
    (SETQ DEV (\DEVICESYMBOL DEV))
    (PROG (BWFACE POS OLDPOS BITSPERPIXEL BACKCOLOR FORECOLOR ANSWER)

     (* ;; "First get a FONTFACE ANSWER.")

          [SETQ ANSWER (COND
                          ((type? FONTFACE FACE)
                           FACE)
                          ((LITATOM FACE)
                           (OR (U-CASEP FACE)
                               (SETQ FACE (U-CASE FACE)))
                           (SETQ POS (STRPOS "-" FACE))
                           (COND
                              [POS (SETQ BWFACE (SUBATOM FACE 1 (SUB1 POS]
                              (T (SETQ BWFACE FACE)))
                           [SETQ ANSWER (SELECTQ BWFACE
                                            ((* ***) 
                                                 (CONSTANT (create FONTFACE
                                                                  WEIGHT _ '*
                                                                  SLOPE _ '*
                                                                  EXPANSION _ '*)))
                                            ((NIL MRR STANDARD NNN) 
                                                 (CONSTANT (create FONTFACE)))
                                            ((ITALIC MIR) 
                                                 (CONSTANT (create FONTFACE
                                                                  SLOPE _ 'ITALIC)))
                                            ((BOLD BRR) 
                                                 (CONSTANT (create FONTFACE
                                                                  WEIGHT _ 'BOLD)))
                                            ((BOLDITALIC BIR) 
                                                 (CONSTANT (create FONTFACE
                                                                  WEIGHT _ 'BOLD
                                                                  SLOPE _ 'ITALIC)))
                                            (create FONTFACE
                                                   WEIGHT _ (SELCHARQ (NTHCHARCODE FACE 1)
                                                                 (M 'MEDIUM)
                                                                 (B 'BOLD)
                                                                 (L 'LIGHT)
                                                                 (GO ERROR))
                                                   SLOPE _ (SELCHARQ (NTHCHARCODE FACE 2)
                                                                (R 'REGULAR)
                                                                (I 'ITALIC)
                                                                (GO ERROR))
                                                   EXPANSION _ (SELCHARQ (NTHCHARCODE FACE 3)
                                                                    (R 'REGULAR)
                                                                    (C 'COMPRESSED)
                                                                    (E 'EXPANDED)
                                                                    (GO ERROR]
                           (COND
                              (POS                           (* ; "Color FONTFACE.  *")
                                   (SETQ OLDPOS POS)
                                   (SETQ POS (STRPOS "-" FACE (ADD1 OLDPOS)))
                                   (COND
                                      ((NULL POS)
                                       (GO ERROR)))
                                   (SETQ BITSPERPIXEL (\DISPLAYSTREAMTYPEBPP DEV))
                                   (SETQ BACKCOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
                                                                        (SUB1 POS))
                                                          BITSPERPIXEL))
                                   (SETQ OLDPOS POS)
                                   (SETQ FORECOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
                                                                        -1)
                                                          BITSPERPIXEL))
                                                             (* ; 
                                                         "COPY ANSWER to avoid smashing constants.")
                                   (SETQ ANSWER (COPY ANSWER))
                                   (replace (FONTFACE BACKCOLOR) of ANSWER with BACKCOLOR
                                          )
                                   (replace (FONTFACE FORECOLOR) of ANSWER with FORECOLOR
                                          )))
                           ANSWER)
                          (T (GO ERROR]

     (* ;; "Coerce on or off COLOR.")

          (SETQ ANSWER (COND
                          ((AND (NOT (FMEMB DEV \COLORDISPLAYSTREAMTYPES))
                                (fetch (FONTFACE COLOR) of ANSWER))
                           (SETQ ANSWER (COPY ANSWER))
                           (replace (FONTFACE COLOR) of ANSWER with NIL)
                           ANSWER)
                          ((AND (FMEMB DEV \COLORDISPLAYSTREAMTYPES)
                                (NULL (fetch (FONTFACE COLOR) of ANSWER)))
                           (SETQ FACE (COPY FACE))
                           (replace (FONTFACE BACKCOLOR) of ANSWER with 0)
                           (replace (FONTFACE FORECOLOR) of ANSWER with
                                                                           (MAXIMUMCOLOR (
                                                                                \DISPLAYSTREAMTYPEBPP
                                                                                          DEV)))
                           ANSWER)
                          (T ANSWER)))
          (RETURN ANSWER)
      ERROR
          (COND
             (NOERRORFLG (RETURN NIL))
             (T (\ILLEGAL.ARG FACE])

(\FONTFILENAME
  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)               (* ; "Edited  5-Mar-93 16:10 by rmk:")

    (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.  New name is of the form %"familysize-face-Ccharset.ext%", e.g., MODERN12-MRR-C357.WD")

    (* ;; "**bvm 10/5/89 Slight change: partition fonts into subdirectories by charset, e.g., all Charset zero fonts are in subdirectory C0>.  This significantly speeds up any font operation that requires any local directory work (e.g., NFS servers on both Sun and D machine), and FONTSAVAILABLE on any device (since it doesn't have to wade thru all those charsets).  This behavior is conditioned on the value of *USEOLDFONTDIRECTORIES*")

    (SETQ FACE (\FONTFACE FACE))                         (* ; "Validate face")
    (LET* ([SIZEPATT (COND
                        ((EQ SIZE '*)
                         SIZE)
                        ((FIXP SIZE)
                         (if (< SIZE 10)
                             then (CONCAT 0 SIZE)
                           else SIZE))
                        (T (\ILLEGAL.ARG SIZE]
           (CSETNAME (COND
                        ((OR (NULL CHARSET)
                             (EQ CHARSET 0))                 (* ; "Charset defaults to zero.")
                         "0")
                        ((FIXP CHARSET)
                         (LET ((*PRINT-BASE* 8)
                               (*PRINT-RADIX* NIL))          (* ; "Longhand for (cl:write-to-string charset :radix nil :base 8), which is twice as slow, due to lousy keyword handling")
                              (\PRINDATUM.TO.STRING CHARSET)))
                        (T                                   (* ; 
                                                           "Somebody made the string already?")
                           CHARSET)))
           [FACESPEC (LIST (CHCON1 (fetch (FONTFACE WEIGHT) of FACE))
                           (CHCON1 (fetch (FONTFACE SLOPE) of FACE))
                           (CHCON1 (fetch (FONTFACE EXPANSION) of FACE]
           (TAIL FACESPEC))
          [if (OR (EQ (CAR TAIL)
                          (CHARCODE *))
                      (EQ (CAR (SETQ TAIL (CDR TAIL)))
                          (CHARCODE *)))
              then                                       (* ; 
            "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower.")
                    (while (EQ (CADR TAIL)
                                   (CHARCODE *)) do (RPLACD TAIL (CDDR TAIL]

          (* ;; "Fortunately, CONCAT ignores packages.")

          (PACKFILENAME.STRING 'NAME (CONCAT (CL:IF *USEOLDFONTDIRECTORIES*
                                                 ""
                                                 (CONCAT (PROGN 
                                                             (* ; 
                   "Lowercase because it's in a directory name, so maybe Unix will find it sooner?")
                                                                "c")
                                                        CSETNAME ">"))
                                            FAMILY SIZEPATT "-" (CONCATCODES FACESPEC)
                                            "-C" CSETNAME)
                 'EXTENSION EXTENSION])

(\FONTFILENAME.OLD
  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)           (* ; "Edited 23-Sep-92 18:22 by jds")

    (* ;; "Returns old style font file names.  They were ambiguous because you could not ask for e.g. FACE (MEDIUM * REGULAR) because it maps to FamilySize-*-Charset, which also matches (BOLD * COMPRESSED), etc.  Keep this function around though for user's who don't rename their files.")
                                                             (* ; 
                     "Returns the name of the file that should contain the information for a font.")
    (SETQ FACE (\FONTFACE FACE))                         (* ; "Force legal canonical face")
    (SETQ FACE (COND
                  ((AND (EQ (CAR FACE)
                            '*)
                        (EQ (CADR FACE)
                            '*))

                   (* ;; "Avoid  adjacent wildcards because DSK gets slower exponentially (can take loooong tiiiiiime).  No need to check compression.")

                   '*)
                  (T FACE)))
    (PACKFILENAME.STRING 'NAME [PROGN 
                                      (* ;; "DISPLAYFONT AC WD and the default case")

                                      (CONCAT (CDR (SASSOC FAMILY *DISPLAY-FONT-NAME-MAP*))
                                             (COND
                                                ((EQ SIZE '*)
                                                 SIZE)
                                                ((FIXP SIZE)
                                                 (COND
                                                    ((< SIZE 10)
                                                     (CONCAT 0 SIZE))
                                                    (T SIZE)))
                                                (T (\ILLEGAL.ARG SIZE)))
                                             [COND
                                                ((EQ FACE '*)
                                                 '*)
                                                (T (SELECTQ (fetch WEIGHT of FACE)
                                                       (BOLD (SELECTQ (fetch SLOPE of FACE)
                                                                 (ITALIC "D")
                                                                 "B"))
                                                       (SELECTQ (fetch SLOPE of FACE)
                                                           (ITALIC "I")
                                                           "R"]
                                             (COND
                                                ((FIXP CHARSET)
                                                 (LET ((*PRINT-BASE* 8))
                                                      (CL:FORMAT NIL "~O" CHARSET)))
                                                (T "000"]
           'EXTENSION EXTENSION])

(\FONTFILENAME.NEW
  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)           (* ; "Edited 30-Mar-87 20:00 by FS")

    (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.")

    (LET (NAME SIZEPATT)
         (SETQ FACE (\FONTFACE FACE))                    (* ; "Validate face")
         [SETQ SIZEPATT (COND
                           ((EQ SIZE '*)
                            SIZE)
                           ((FIXP SIZE)
                            (if (< SIZE 10)
                                then (CONCAT 0 SIZE)
                              else SIZE))
                           (T (\ILLEGAL.ARG SIZE]

         (* ;; "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower.  Nicely, PACK & CONCAT ignore packages.")

         (PACKFILENAME.STRING 'NAME (CONCAT FAMILY SIZEPATT "-"
                                           [COND
                                              ((EQUAL FACE '

         (* * *)
)
                                               '*)
                                              (T (CONCAT (NTHCHAR (fetch (FONTFACE WEIGHT)
                                                                     of FACE)
                                                                1)
                                                        (NTHCHAR (fetch (FONTFACE SLOPE)
                                                                    of FACE)
                                                               1)
                                                        (NTHCHAR (fetch (FONTFACE EXPANSION)
                                                                    of FACE)
                                                               1]
                                           (COND
                                              [(FIXP CHARSET)
                                               (LET ((*PRINT-BASE* 8))
                                                    (CONCAT "-C" (\PRINDATUM.TO.STRING CHARSET]
                                              (CHARSET (CONCAT "-C" CHARSET))
                                              (T "-C0")))
                'EXTENSION EXTENSION])

(\FONTINFOFROMFILENAME
  [LAMBDA (FONTFILE DEVICE)                                  (* ; "Edited 14-Sep-96 10:23 by rmk:")
                                                             (* ; "Edited  5-Oct-89 18:28 by bvm")

    (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.  Rotation is 0 always.  Parses both new & old format files.")

    (LET ((FILENAMELIST (UNPACKFILENAME.STRING FONTFILE))
          CH SIZEBEG SIZEND NAME FAMILY SIZE FACE EXT)
         (SETQ NAME (LISTGET FILENAMELIST 'NAME))            (* ; 
         "find where the name and size are.  MUST check for ch nil below or possible infinite loop")
         (SETQ SIZEBEG (for CH# from 1 when (OR (NUMBERP (SETQ CH (NTHCHAR NAME CH#)))
                                                            (NULL CH)) do (RETURN CH#)))

         (* ;; "Get Family")

         [SETQ FAMILY (MKATOM (U-CASE (SUBSTRING NAME 1 (SUB1 SIZEBEG]

         (* ;; "Get Size")

         [SETQ SIZEND (find CH# from SIZEBEG suchthat (NOT (NUMBERP (NTHCHAR NAME CH#]
         [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
         (if (EQ (NTHCHAR NAME SIZEND)
                     '-)
             then (SETQ SIZEND (ADD1 SIZEND)))

         (* ;; "Get Face")

         (SETQ NAME (U-CASE NAME))                           (* ; 
                                                   "don't need name, but checks for lowercase face")
         [SETQ FACE (LIST (COND
                             ((STRPOS "B" NAME SIZEND NIL T NIL UPPERCASEARRAY)
                              'BOLD)
                             ((STRPOS "L" NAME SIZEND NIL T NIL UPPERCASEARRAY)
                              'LIGHT)
                             (T 'MEDIUM))
                          (COND
                             ((STRPOS "I" NAME SIZEND NIL NIL NIL UPPERCASEARRAY)
                              'ITALIC)
                             (T 'REGULAR))
                          (COND
                             ((STRPOS "E" NAME SIZEND NIL NIL NIL UPPERCASEARRAY)
                              'EXPANDED)
                             ((STRPOS "C-" NAME SIZEND NIL NIL NIL UPPERCASEARRAY)
                              'COMPRESSED)
                             (T 'REGULAR]
         (LIST FAMILY SIZE FACE 0 (COND
                                     ((STREAMP DEVICE)
                                      (IMAGESTREAMTYPE DEVICE))
                                     ((NULL DEVICE)
                                      [SETQ EXT (MKATOM (U-CASE (LISTGET FILENAMELIST 'EXTENSION]
                                      (SELECTQ EXT
                                          (WD 'INTERPRESS)
                                          ((STRIKE AC DISPLAYFONT) 
                                               'DISPLAY)
                                          EXT))
                                     ((LITATOM DEVICE)
                                      (\FONTSYMBOL DEVICE))
                                     (T DEVICE])

(\FONTINFOFROMFILENAME.OLD
  [LAMBDA (FONTFILE DEVICE)                              (* ; "Edited  1-Jan-87 01:29 by FS")

    (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.")

    (PROG ((FILENAMELIST (UNPACKFILENAME FONTFILE))
           SIZEBEG SIZEND NAME FAMILY SIZE)
          (SETQ NAME (LISTGET FILENAMELIST 'NAME))           (* ; 
                                                           "find where the name and size are.")
          (SETQ SIZEBEG (for CH# from 1 when (NUMBERP (NTHCHAR NAME CH#))
                           do (RETURN CH#)))
          [SETQ FAMILY (MKATOM (SUBSTRING NAME 1 (SUB1 SIZEBEG]
          (SETQ SIZEND (for CH# from SIZEBEG when (NOT (NUMBERP (NTHCHAR NAME CH#)))
                          do (RETURN CH#)))
          [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
          (RETURN (LIST FAMILY SIZE (SELECTQ (LISTGET FILENAMELIST 'EXTENSION)
                                        ((DISPLAYFONT AC WD) 
                                             (LIST (COND
                                                      ((STRPOS "-B" NAME SIZEND NIL T)
                                                       'BOLD)
                                                      (T 'MEDIUM))
                                                   (COND
                                                      ((STRPOS "-I" NAME SIZEND NIL)
                                                       'ITALIC)
                                                      (T 'REGULAR))
                                                   'REGULAR))
                                        (LIST (COND
                                                 ((STRPOS "B" NAME SIZEND NIL T)
                                                  'BOLD)
                                                 (T 'MEDIUM))
                                              (COND
                                                 ((STRPOS "I" NAME SIZEND NIL)
                                                  'ITALIC)
                                                 (T 'REGULAR))
                                              'REGULAR))
                        0 DEVICE])

(\GETFONTDESC
  [LAMBDA (SPEC DEVICE NOERRORFLG)                       (* J.Gibbons " 5-Dec-82 16:53")

    (* ;; "Coerces SPEC to a fontdescriptor")
                                                             (* ; 
                                                "\GETFONTDESC HAS MACRO, BUT OLD CALLS STILL EXIST")
    (\COERCEFONTDESC SPEC DEVICE NOERRORFLG])

(\COERCEFONTDESC
  [LAMBDA (SPEC STREAM NOERRORFLG)                       (* ; "Edited 29-Aug-91 12:19 by jds")

    (* ;; "Coerces SPEC to a fontdescriptor appropriate for STREAM.  Go back thru FONTCREATE for various coercions in order to make sure that the cache gets set up")

    (DECLARE (GLOBALVARS DEFAULTFONT))
    (PROG (FONT DEVICE)
          [COND
             ((type? FONTDESCRIPTOR SPEC)
              (SETQ FONT SPEC))
             [(type? FONTCLASS SPEC)
              [SETQ DEVICE (COND
                              ((NULL STREAM)                 (* ; "Default is display")

                               (* ;; "COULDN'T THIS BRANCH BE INTENDED TO MEAN 4DISPLAY, 8DISPLAY, 24DISPLAY?  PEOPLE PROBABLY SHOULDN'T BE CALLING \COERCEFONTDESC WITH STREAM = NIL.")

                               'DISPLAY)
                              ((IMAGESTREAMP STREAM)
                               (IMAGESTREAMTYPE STREAM))
                              ((LITATOM STREAM)
                               (\DEVICESYMBOL STREAM))
                              (STREAM STREAM)
                              (T 
                                 (* ;; "I don't think this case should be allowed.")

                                 'DISPLAY]
              [SETQ FONT (SELECTQ DEVICE
                             (DISPLAY (fetch (FONTCLASS DISPLAYFD) of SPEC))
                             (INTERPRESS (fetch (FONTCLASS INTERPRESSFD) of SPEC))
                             (PRESS (fetch (FONTCLASS PRESSFD) of SPEC))
                             (CDR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of SPEC]
              (RETURN (COND
                         ((type? FONTDESCRIPTOR FONT)

                          (* ;; 
     "We don't always create FD's for devices before they are needed, so do it now and save result")

                          FONT)
                         [(NULL FONT)

                          (* ;; "NIL means create FONT but don't cache.")

                          (COND
                             ((AND (FMEMB DEVICE \DISPLAYSTREAMTYPES)
                                   (SETQ FONT (\COERCEFONTDESC SPEC 'DISPLAY NOERRORFLG))
                                   (SETQ FONT (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG))
                                   )

                              (* ;; 
                            "Coerce existing black & white font to color font, but don't cache.")

                              FONT)
                             [(EQ SPEC DEFAULTFONT)

                              (* ;; "Break cycles with NIL in the defaultfont")

                              (COND
                                 (NOERRORFLG NIL)
                                 ((EQ DEVICE 'DISPLAY)

                                  (* ;; "Function DEFAULTFONT guarantees system integrity")

                                  (DEFAULTFONT 'DISPLAY))
                                 ((EQUAL DEVICE '(HARDCOPY DISPLAY))

                                  (* ;; 
                "MAKE DISPLAY-HARDCOPY FONTS default to the corresponding display font, copied....")

                                  (FONTCOPY (DEFAULTFONT 'DISPLAY)
                                         'DEVICE STREAM 'NOERROR NOERRORFLG))
                                 (T (ERROR (CONCAT DEVICE " component for DEFAULTFONT undefined"]
                             (T (FONTCREATE DEFAULTFONT NIL NIL NIL STREAM NOERRORFLG]
                         ((SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM NOERRORFLG))

                          (* ;; "Might get NIL if NOERRORFLG")

                          (SETFONTCLASSCOMPONENT SPEC DEVICE FONT]
             ((NULL SPEC)
              (RETURN (\COERCEFONTDESC DEFAULTFONT STREAM NOERRORFLG)))
             ((OR (IMAGESTREAMP SPEC)
                  (type? WINDOW SPEC))
              (SETQ FONT (DSPFONT NIL SPEC)))
             (T 
                (* ;; "If called with NOERRORFLG=T (e.g.  from DSPFONT) we want to suppress invalid arg errors as well as font not found, so we can move on to other possible coercions.")

                (RETURN (FONTCREATE SPEC NIL NIL NIL STREAM NOERRORFLG]

     (* ;; "Here if arg was a fontdescriptor or imagestream")

          (RETURN (COND
                     ((NULL STREAM)

                      (* ;; 
                    "NIL device doesn't default to display if a fully-specified font was found")

                      FONT)
                     ([OR (EQ STREAM (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT))
                          (AND (type? STREAM STREAM)
                               (EQ (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM
                                                                                         IMAGEOPS)
                                                                                of STREAM))
                                   (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT]
                      FONT)
                     (T 
                        (* ;; "Here if doesn't match or if DEVICE is not explicitly a stream.")

                        (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG])

(\LOOKUPFONT
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)             (* ; "Edited 28-Jul-88 17:05 by rmk:")
                                                             (* ; "Edited 28-Jul-88 17:04 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:02 by rmk:")
                                                             (* ; "Edited 28-Jul-88 13:54 by rmk:")
                                                             (* ; "Edited 26-Feb-87 00:20 by FS")

    (* ;; "looks up a font in the internal cache.  SASSOC for listp FACE")

    (DECLARE (GLOBALVARS \FONTSINCORE))

    (* ;; "Someone had better have already made FACE canonical")

    (LET [(X (CDR (FASSOC ROTATION (CDR (SASSOC FACE (CDR (FASSOC SIZE (CDR (OR (FASSOC FAMILY 
                                                                                       \FONTSINCORE)
                                                                                (\FONT.SYMBOLASSOC
                                                                                 FAMILY \FONTSINCORE]
         (CDR (OR (FASSOC DEVICE X)
                  (\FONT.SYMBOLASSOC DEVICE X])

(\LOOKUPFONTSINCORE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)                 (* ; "Edited 25-Apr-93 13:07 by rmk:")
                                                             (* rrb "25-Sep-84 12:10")

(* ;;; "returns a list of the fonts that are available in core.  * is used to match anything.")

    (DECLARE (GLOBALVARS \FONTSINCORE))
    (for FAMBUCKET in \FONTSINCORE when (OR (EQ FAMILY '*)
                                                        (EQ FAMILY (CAR FAMBUCKET)))
       join (for SIZEBUCKET in (CDR FAMBUCKET) when (OR (EQ SIZE '*)
                                                                        (EQ SIZE (CAR SIZEBUCKET)))
                   join (for FACEBUCKET in (CDR SIZEBUCKET)
                               when (OR (EQ FACE '*)
                                            (EQUAL FACE (CAR FACEBUCKET)))
                               join (for ROTBUCKET in (CDR FACEBUCKET)
                                           when (OR (EQ ROTATION '*)
                                                        (EQ ROTATION (CAR ROTBUCKET)))
                                           join (for DEVBUCKET in (CDR ROTBUCKET)
                                                       when (AND (OR (EQ DEVICE '*)
                                                                         (EQ DEVICE (CAR DEVBUCKET)))
                                                                     (TYPE? FONTDESCRIPTOR
                                                                            (CDR DEVBUCKET)))
                                                       collect (LIST (CAR FAMBUCKET)
                                                                         (CAR SIZEBUCKET)
                                                                         (CAR FACEBUCKET)
                                                                         (CAR ROTBUCKET)
                                                                         (CAR DEVBUCKET])

(\READDISPLAYFONTFILE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)         (* ; "Edited  8-Oct-96 10:17 by rmk:")
                                                             (* ; 
                                                           "Edited 30-Sep-96 12:03 by kaplan")
                                                             (* ; "Edited  2-Jan-87 17:55 by FS")

    (* ;; "Look for new filename convention, then old file name convention, with extensions.   If CACHEDISPLAYFONTS, this keeps a cache of what was read, on the canonical filename's property list, so that NSDISPLAYSIZES and SMALLSCREEN size coercions can be done and undone without always going out to the directories.")

    (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES CACHEDISPLAYFONTS))
    (BIND FONTFILE CSINFO STRM
       FIRST 

             (* ;; "Cache is indexed by canonical font file name, without the extension fields.")

             (CL:WHEN 
                 [AND CACHEDISPLAYFONTS
                      (FIND EXT INSIDE DISPLAYFONTEXTENSIONS
                         SUCHTHAT (SETQ CSINFO
                                       (GETP (L-CASE (FILENAMEFIELD (IF (FMEMB EXT 
                                                                                *OLD-FONT-EXTENSIONS*
                                                                                   )
                                                                        THEN (\FONTFILENAME.OLD
                                                                                  FAMILY SIZE FACE 
                                                                                  EXT CHARSET)
                                                                      ELSE (\FONTFILENAME
                                                                                FAMILY SIZE FACE EXT
                                                                                CHARSET))
                                                            'NAME))
                                             'CACHEDCHARSET]
                 (RETURN (AND (NEQ CSINFO T)
                              (COPYALL CSINFO)))) FOR EXT INSIDE DISPLAYFONTEXTENSIONS
       WHEN (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET 
                                      DISPLAYFONTDIRECTORIES (LIST EXT)))
       DO 

             (* ;; 
          "Cache is indexed by canonical font file name, without the directory or extension fields")

             (SETQ STRM (OPENSTREAM FONTFILE 'INPUT))
             (RESETLST
                 [SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T)
                                  (STRIKE (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                                                               STRM))
                                          (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE))
                                  (AC 
                                      (* ;; "CLOSEF is guaranteed inside \READACFONTFILE, against the possibility that we have to copy to make randaccessp")

                                      (\READACFONTFILE STRM FAMILY SIZE FACE))
                                  (PROG1 (CLOSEF STRM)       (* ; 
"This would get done by RESETSAVE if AC's were read sequentially and we could factor the RESETSAVE")
                                      (SHOULDNT))])
             (CL:WHEN CACHEDISPLAYFONTS
                 (PUTPROP (L-CASE (FILENAMEFIELD FONTFILE 'NAME))
                        'CACHEDCHARSET CSINFO)
                 (SETQ CSINFO (COPYALL CSINFO))) 

             (* ;; "If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also be nice to tell the user that he has a bogus file.")

             (RETURN CSINFO)
       FINALLY 

             (* ;; "Didn't find the file, cache T to suppress future lookups")

             (CL:WHEN CACHEDISPLAYFONTS
                 (PUTPROP (L-CASE (FILENAMEFIELD (IF (FMEMB (CAR (MKLIST DISPLAYFONTEXTENSIONS))
                                                                *OLD-FONT-EXTENSIONS*)
                                                     THEN (\FONTFILENAME.OLD
                                                               FAMILY SIZE FACE (CAR (MKLIST 
                                                                                DISPLAYFONTEXTENSIONS
                                                                                            ))
                                                               CHARSET)
                                                   ELSE (\FONTFILENAME FAMILY SIZE FACE
                                                                   (CAR (MKLIST DISPLAYFONTEXTENSIONS
                                                                               ))
                                                                   CHARSET))
                                         'NAME))
                        'CACHEDCHARSET T))])
)



(* ;; 
"\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories.  That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places.  "
)


(ADDTOVAR *OLD-FONT-EXTENSIONS* STRIKE)

(RPAQ? *USEOLDFONTDIRECTORIES* NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)
)



(* ;; 
"Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)"
)




(* ;; 
"Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)"
)


(RPAQ? CACHEDISPLAYFONTS T)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS CACHEDISPLAYFONTS)
)



(* ; "STRIKE format file support")

(DEFINEQ

(\READSTRIKEFONTFILE
  [LAMBDA (STRM FAMILY SIZE FACE)                        (* ; "Edited  4-Dec-92 12:11 by jds")
                                                             (* ; 
                             "STRM has already been determined to be a vanilla strike-format file.")
                                                             (* ; "returns a charsetinfo")
    (COND
       ((NEQ 2 (GETFILEPTR STRM))
        (SETFILEPTR STRM 2)))
    (PROG (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
          (SETQ CSINFO (create CHARSETINFO))
          (SETQ FIRSTCHAR (\WIN STRM))                       (* ; "minimum ascii code")
          (SETQ LASTCHAR (\WIN STRM))                        (* ; "maximum ascii code")
          (\WIN STRM)                                        (* ; 
                                                           "MaxWidth which isn't used by anyone.")
          (\WIN STRM)                                        (* ; 
                                                           "number of words in this StrikeBody")
          (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM))
                                                             (* ; 
                                                           "ascent in scan lines (=FBBdy+FBBoy)")
          (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM))
                                                             (* ; "descent in scan-lines (=FBBoy)")
          (\WIN STRM)                                        (* ; 
                                                  "offset in bits (<0 for kerning, else 0, =FBBox)")
          (SETQ RW (\WIN STRM))                              (* ; "raster width of bitmap")
                                                             (* ; "height of bitmap")

     (* ;; "JDS 12/4/92:  Apparently, these fields can be signed values, if all chars, e.g., ride above the base line.")

          (SETQ HEIGHT (IPLUS (SIGNED (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                                     16)
                              (SIGNED (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)
                                     16)))
          (SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
                              HEIGHT))
          (\BINS STRM (fetch BITMAPBASE of BITMAP)
                 0
                 (UNFOLD (ITIMES RW HEIGHT)
                        BYTESPERWORD))                       (* ; "read bits into bitmap")
          (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)
          (SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR)
                                 3))                         (* (SETQ OFFSETS (ARRAY
                                                           (IPLUS \MAXCHAR 3)
                                                           (QUOTE SMALLPOSP) 0 0)))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
                                                             (* ; "initialise the offsets to 0")
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0))
                                                             (* (AIN OFFSETS FIRSTCHAR NUMBCODES 
                                                           STRM))
          (for I from FIRSTCHAR as J from 1 to NUMBCODES
             do (\FSETOFFSET OFFSETS I (\WIN STRM)))
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0))
                                                             (* (replace WIDTHS of
                                                           (CHARSETINFO CSINFO) with
                                                           (ARRAY (IPLUS \MAXCHAR 3)
                                                           (QUOTE SMALLPOSP) 0 0)))
          (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
          (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO
                                                                                    WIDTHS)
                                                                           of CSINFO))
          (RETURN CSINFO])

(\SFMAKEBOLD
  [LAMBDA (CSINFO)                                       (* gbn "25-Jul-85 04:52")
    (PROG* ((OLDCHARBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
            (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
            (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
            (HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                           (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
            NEWCHARBITMAP OFFSET UNKNOWNOFFSET UNKNOWNWIDTH)
           (SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP)
                                      (fetch BITMAPHEIGHT of OLDCHARBITMAP)))
           (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXCHAR)))
           (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXCHAR)))
           [for I from 0 to \MAXCHAR
              do (COND
                        ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                             UNKNOWNOFFSET)                  (* ; 
             "if this is the magic charcode with the slug image (charcode 256) then leave it alone")
                         NIL)
                        (T                                   (* ; 
                                                          "overlap two blts to produce bold effect")
                           (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP OFFSET 0 (\FGETWIDTH WIDTHS I
                                                                                        )
                                  HEIGHT
                                  'INPUT
                                  'REPLACE)
                           (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP (ADD1 OFFSET)
                                  0
                                  (SUB1 (\FGETWIDTH WIDTHS I))
                                  HEIGHT
                                  'INPUT
                                  'PAINT]                    (* ; 
                                                          "fill in the slug for the magic charcode")
           (BITBLT OLDCHARBITMAP UNKNOWNOFFSET 0 NEWCHARBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
                  'INPUT
                  'REPLACE)
           (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWCHARBITMAP])

(\SFMAKEITALIC
  [LAMBDA (CSINFO)                                       (* gbn "18-Sep-85 17:57")
    (PROG ((WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
           (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
           (ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
           (DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
           (OLDBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
           HEIGHT OFFSET NEWBITMAP WIDTH UNKNOWNOFFSET UNKNOWNWIDTH N M R XN XX YN YX)
          (SETQ HEIGHT (IPLUS ASCENT DESCENT))
          (SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP)
                                 (fetch BITMAPHEIGHT of OLDBITMAP)))
          (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR)))
          (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR)))
          (SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3)
                                        4)))
          (SETQ M (IQUOTIENT (IPLUS ASCENT 3)
                         4))
          [for I from 0 to \MAXTHINCHAR
             do (COND
                       ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                            UNKNOWNOFFSET)                   (* ; 
             "if this is the magic charcode with the slug image (charcode 256) then leave it alone")
                        NIL)
                       (T (SETQ WIDTH (\FGETWIDTH WIDTHS I))
                          (for J from N to M
                             do (SETQ R (IPLUS OFFSET WIDTH))
                                   (SETQ XN (IMIN R (IMAX (IPLUS OFFSET J)
                                                          0)))
                                   (SETQ XX (IMIN R (IMAX (IPLUS R J)
                                                          0)))
                                   [SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4]
                                   [SETQ YX (IMIN HEIGHT (IPLUS DESCENT (IPLUS (ITIMES J 4)
                                                                               4]
                                   (COND
                                      ((AND (IGREATERP XX XN)
                                            (IGREATERP YX YN))
                                       (BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN (IDIFFERENCE
                                                                                    XX XN)
                                              (IDIFFERENCE YX YN)
                                              'INPUT
                                              'REPLACE]
          (BITBLT OLDBITMAP UNKNOWNOFFSET 0 NEWBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
                 'INPUT
                 'REPLACE)
          (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWBITMAP])

(\SFMAKEROTATEDFONT
  [LAMBDA (FONTDESC ROTATION)                            (* ; "Edited 30-Mar-87 20:35 by FS")

    (* ;; "takes a fontdecriptor and rotates it.")

    (* ;; "1/5/86 JDS.  Masterscope claims nobody calls this.  Let's find out....")

    (HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields")
                                                             (* (create FONTDESCRIPTOR using 
                                                           FONTDESC (SETQ CHARACTERBITMAP
                                                           (\SFROTATEFONTCHARACTERS
                                                           (fetch (FONTDESCRIPTOR 
                                                           CHARACTERBITMAP) of FONTDESC) 
                                                           ROTATION)) (SETQ ROTATION ROTATION)
                                                           (SETQ \SFOffsets (
                                                           \SFFIXOFFSETSAFTERROTATION FONTDESC 
                                                           ROTATION)) (SETQ FONTCHARSETVECTOR
                                                           (\ALLOCBLOCK (ADD1 \MAXCHARSET) T))))

    (* ;; "If you uncomment out the code above, remove this comment and the NIL below")

    NIL])

(\SFROTATECSINFO
  [LAMBDA (CSINFO ROTATION)                              (* gbn "15-Sep-85 14:38")

    (* ;; "takes a CHARSETINFO and rotates it and produces a rotated equivalent one.")

    (create CHARSETINFO using CSINFO CHARSETBITMAP _ (\SFROTATEFONTCHARACTERS
                                                              (fetch (CHARSETINFO CHARSETBITMAP)
                                                                 of CSINFO)
                                                              ROTATION)
                                  OFFSETS _ (\SFROTATECSINFOOFFSETS CSINFO ROTATION])

(\SFROTATEFONTCHARACTERS
  [LAMBDA (CHARBITMAP ROTATION)                          (* ; "Edited 22-Sep-87 10:38 by Snow")

(* ;;; "rotate a bitmap either 90 or 270 for fonts.")

    (CASE ROTATION
        (0 CHARBITMAP)
        (90 (ROTATE-BITMAP-LEFT CHARBITMAP))
        (180 (ROTATE-BITMAP (ROTATE-BITMAP CHARBITMAP)))
        (270 (ROTATE-BITMAP CHARBITMAP)))])

(\SFFIXOFFSETSAFTERROTATION
  [LAMBDA (FONTDESC ROTATION)                            (* ; "Edited 30-Mar-87 20:35 by FS")

    (* ;; "adjusts offsets in case where rotation turned things around.")

    (HELP "NEED TO UPDATE THIS FN TO NSCHARS & NEW FONT FIELDS")
                                                             (* (COND ((EQ ROTATION 270)
                                                           (PROG ((OFFSETS (fetch
                                                           (FONTDESCRIPTOR \SFOffsets) of 
                                                           FONTDESC)) (WIDTHS
                                                           (fetch (FONTDESCRIPTOR \SFWidths) of 
                                                           FONTDESC)) (BITMAPHEIGHT
                                                           (BITMAPWIDTH (fetch
                                                           (FONTDESCRIPTOR CHARACTERBITMAP) of 
                                                           FONTDESC))) NEWOFFSETS)
                                                           (SETQ NEWOFFSETS (COPYARRAY OFFSETS))
                                                           (for CHARCODE from 0 to \MAXCHAR do
                                                           (SETA NEWOFFSETS CHARCODE
                                                           (IDIFFERENCE BITMAPHEIGHT
                                                           (IPLUS (ELT OFFSETS CHARCODE)
                                                           (ELT WIDTHS CHARCODE)))))
                                                           (* ; 
                                         "may be some problem with dummy character representation.")
                                                           (RETURN NEWOFFSETS)))
                                                           (T (fetch (FONTDESCRIPTOR \SFOffsets)
  of FONTDESC))))

    (* ;; "If you uncomment out the code above, remove this comment and the NIL below")

    NIL])

(\SFROTATECSINFOOFFSETS
  [LAMBDA (CSINFO ROTATION)                              (* gbn "15-Sep-85 14:36")
                                                             (* ; 
                                     "adjusts offsets in case where rotation turned things around.")
    (COND
       ((EQ ROTATION 270)
        (PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
               (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
               (BITMAPHEIGHT (BITMAPWIDTH (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)))
               NEWOFFSETS)
              (SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
              [for CHARCODE from 0 to \MAXCHAR
                 do (\FSETOFFSET NEWOFFSETS CHARCODE (IDIFFERENCE BITMAPHEIGHT
                                                                (IPLUS (\FGETOFFSET OFFSETS CHARCODE)
                                                                       (\FGETWIDTH WIDTHS CHARCODE]
                                                             (* ; 
                                         "may be some problem with dummy character representation.")
              (RETURN NEWOFFSETS)))
       (T (fetch (CHARSETINFO OFFSETS) of CSINFO])

(\SFMAKECOLOR
  [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL)    (* kbr%: " 6-Feb-86 18:17")

    (* ;; "makes a csinfo that has a character bitmap that is colorized.")

    (PROG (CHARACTERBITMAP COLORCSINFO)
          [COND
             ((IMAGESTREAMP BITSPERPIXEL)
              (OR BACKCOLOR (SETQ BACKCOLOR (DSPBACKCOLOR NIL BITSPERPIXEL)))
              (OR FORECOLOR (SETQ FORECOLOR (DSPCOLOR NIL BITSPERPIXEL)))
              (SETQ BITSPERPIXEL (IMAGESTREAMTYPE BITSPERPIXEL]
          [SETQ BITSPERPIXEL (COND
                                ((NUMBERP BITSPERPIXEL)
                                 BITSPERPIXEL)
                                (T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL]
          (SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL))
          (SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL))
          (SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of 
                                                                                             BWCSINFO
                                                       )
                                       BACKCOLOR FORECOLOR BITSPERPIXEL))
          (SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP _ 
                                                          CHARACTERBITMAP))
          (RETURN COLORCSINFO])
)
(DEFINEQ

(WRITESTRIKEFONTFILE
  [LAMBDA (FONT CHARSET FILENAME)                        (* ; "Edited 30-Mar-87 20:25 by FS")

    (* ;; "Write strike FILE using info in FONT, AND CHARSET number.")

    (* ;; "This code only works if original file was STRIKE.  Otherwise, a new CSINFO is dummied up and it is used instead.  So, CSINFO when read in might be different than the one written out.")

    (PROG (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTHS OFFSETS IMWIDTHS MAXWIDTH RASTERWIDTH LENGTH 
                 DUMMYCHAR DUMMYOFFSET DUMMYINDEX WIDTH OFFSET CODE MAXCODE)
          (SETQ MAXCODE 255)                                 (* ; "Max charcode")
          (SETQ DUMMYINDEX 256)                              (* ; "Dummy char marker")
          (COND
             ((NOT (FONTP FONT))
              (LISPERROR "ILLEGAL ARG" FONT)))
          (COND
             ((NULL CHARSET)
              (SETQ CHARSET 0))
             ((NOT (AND (IGEQ CHARSET 0)
                        (ILESSP CHARSET \MAXCHARSET)))
              (LISPERROR "ILLEGAL ARG" CHARSET)))
          (SETQ CSINFO (STRIKECSINFO (\GETCHARSETINFO CHARSET FONT T)))
                                                             (* ; 
                                                           "Guarantee its a STRIKE font CSINFO.")
          (COND
             ((NULL CSINFO)
              (ERROR "Couldn't find charset " CHARSET)))
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
          (SETQ IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))

     (* ;; "Index 256 contains a dummy width; use it's value to determine missing chars")

          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX))
          [SETQ FIRSTCHAR (for I from 0 to MAXCODE
                             thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
                                                  DUMMYOFFSET]
          [SETQ LASTCHAR (for I from MAXCODE to 0 by -1
                            thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
                                                 DUMMYOFFSET]
          (SETQ DUMMYCHAR (ADD1 LASTCHAR))
          [SETQ STREAM (OPENSTREAM FILENAME 'OUTPUT 'NEW '((TYPE BINARY]

     (* ;; "")

     (* ;; "STRIKE Header")

     (* ;; "")

          (\WOUT STREAM 32768)
          (\WOUT STREAM FIRSTCHAR)
          (\WOUT STREAM LASTCHAR)
          (SETQ MAXWIDTH 0)
          [for I from 0 to DUMMYINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH
                                                                              (\FGETWIDTH WIDTHS I]
          (\WOUT STREAM MAXWIDTH)

     (* ;; "")

     (* ;; "STRIKE Body")

     (* ;; "")

     (* ;; "Length of body")

          (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (CHARSETINFO
                                                                                     CHARSETBITMAP)
                                                                            of CSINFO)))
          (SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR)
                              (ITIMES (fetch (FONTDESCRIPTOR \SFHeight) of FONT)
                                     RASTERWIDTH)))
          (\WOUT STREAM LENGTH)

     (* ;; "Ascent, Descent, Xoffset (no longer used) and Rasterwidth.")

          (\WOUT STREAM (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
          (\WOUT STREAM (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
          (\WOUT STREAM 0)                                   (* ; 
                                                  "offset in bits (<0 for kerning, else 0, =FBBox)")
          (\WOUT STREAM RASTERWIDTH)

     (* ;; "Bitmap")

          [\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (CHARSETINFO CHARSETBITMAP)
                                                                  of CSINFO))
                 0
                 (ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                                              (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]

     (* ;; "Offsets")

          (SETQ CODE 0)
          (\WOUT STREAM CODE)
          (for I from FIRSTCHAR to DUMMYCHAR
             do (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                   (SETQ WIDTH (\FGETWIDTH WIDTHS I))
                   [COND
                      ((AND (IEQP OFFSET DUMMYOFFSET)
                            (NOT (IEQP I DUMMYCHAR)))        (* ; "CODE stays the same.")
                       )
                      (T (SETQ CODE (IPLUS CODE WIDTH]
                   (\WOUT STREAM CODE))
          (CLOSEF STREAM])

(STRIKECSINFO
  [LAMBDA (CSINFO)                                       (* ; "Edited 27-Apr-89 13:39 by atm")

    (* ;; "Returns a STRIKE type font descriptor (EQ WIDTHS IMAGEWIDTHS), cause we know how to write those guys out (they read quicker  but display slower).  If (EQ WIDTHS IMAGEWIDTHS), just return original.")

    (PROG (WIDTHS OFFSETS IMWIDTHS OLDBM BMWIDTH BMHEIGHT NEWBM NEWOFFSET NEWWIDTH OLDOFFSET 
                 DUMMYOFFSET NEWOFFSETS)
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (SETQ IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))
          (if (EQ WIDTHS IMWIDTHS)
              then (RETURN CSINFO))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
          (SETQ OLDBM (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS 256))
          (SETQ BMHEIGHT (BITMAPHEIGHT OLDBM))
          [SETQ BMWIDTH (for I from 0 to \MAXTHINCHAR
                           sum (if (IEQP DUMMYOFFSET (\FGETOFFSET OFFSETS I))
                                       then 0
                                     else (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
                                                    (\FGETWIDTH WIDTHS I]

     (* ;; "")

     (* ;; "Initialize new offsets vector")

     (* ;; "")

          (SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET NEWOFFSETS I 0))
          (\FSETOFFSET NEWOFFSETS (ADD1 \MAXTHINCHAR)
                 BMWIDTH)

     (* ;; "")

     (* ;; "Adjust bitmap with so width = imagewidth, fill offsets")

     (* ;; "")

          (SETQ NEWBM (BITMAPCREATE BMWIDTH BMHEIGHT 1))
          (SETQ NEWOFFSET 0)
          [for I from 0 to 255
             do (SETQ OLDOFFSET (\FGETOFFSET OFFSETS I))
                   (if (IEQP DUMMYOFFSET OLDOFFSET)
                       then (\FSETOFFSET NEWOFFSETS I BMWIDTH)
                     else (\FSETOFFSET NEWOFFSETS I NEWOFFSET)
                           (SETQ NEWWIDTH (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
                                                (\FGETWIDTH WIDTHS I)))
                           (BITBLT OLDBM OLDOFFSET 0 NEWBM NEWOFFSET 0 (\FGETWIDTH IMWIDTHS I)
                                  BMHEIGHT
                                  'REPLACE)
                           (SETQ NEWOFFSET (IPLUS NEWOFFSET NEWWIDTH]

     (* ;; "")

     (* ;; "Make new CSInfo record withs IMAGEWIDTHS, WIDTHS the same")

     (* ;; "")

          (SETQ WIDTHS (COPYALL WIDTHS))
          [for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I
                                                                  (IMAX (\FGETWIDTH WIDTHS I)
                                                                        (\FGETIMAGEWIDTH IMWIDTHS I]
          (RETURN (create CHARSETINFO
                         WIDTHS _ WIDTHS
                         OFFSETS _ NEWOFFSETS
                         IMAGEWIDTHS _ WIDTHS
                         CHARSETBITMAP _ NEWBM
                         YWIDTHS _ (fetch (CHARSETINFO YWIDTHS) of CSINFO)
                         CHARSETASCENT _ (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                         CHARSETDESCENT _ (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO])
)

(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
       '((FONTCLASS 0 (BITS . 7))
         (FONTCLASS 2 POINTER)
         (FONTCLASS 4 POINTER)
         (FONTCLASS 6 POINTER)
         (FONTCLASS 8 POINTER)
         (FONTCLASS 10 POINTER))
       '12)

(/DECLAREDATATYPE 'FONTDESCRIPTOR
       '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD 
               SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 2 POINTER)
         (FONTDESCRIPTOR 4 POINTER)
         (FONTDESCRIPTOR 6 POINTER)
         (FONTDESCRIPTOR 8 (BITS . 15))
         (FONTDESCRIPTOR 9 (BITS . 15))
         (FONTDESCRIPTOR 10 (BITS . 15))
         (FONTDESCRIPTOR 11 (BITS . 15))
         (FONTDESCRIPTOR 12 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 13 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 14 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 15 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 16 POINTER)
         (FONTDESCRIPTOR 18 POINTER)
         (FONTDESCRIPTOR 20 POINTER)
         (FONTDESCRIPTOR 22 POINTER)
         (FONTDESCRIPTOR 24 POINTER)
         (FONTDESCRIPTOR 26 (BITS . 7))
         (FONTDESCRIPTOR 27 (BITS . 15))
         (FONTDESCRIPTOR 28 POINTER)
         (FONTDESCRIPTOR 30 POINTER)
         (FONTDESCRIPTOR 32 POINTER))
       '34)

(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)
       '((CHARSETINFO 0 POINTER)
         (CHARSETINFO 2 POINTER)
         (CHARSETINFO 4 POINTER)
         (CHARSETINFO 6 POINTER)
         (CHARSETINFO 8 POINTER)
         (CHARSETINFO 10 (BITS . 15))
         (CHARSETINFO 11 (BITS . 15))
         (CHARSETINFO 12 POINTER))
       '14)
(ADDTOVAR SYSTEMRECLST

(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
                         DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))

(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
                              (FONTFAMILY POINTER)
                              (FONTSIZE POINTER)
                              (FONTFACE POINTER)
                              (\SFAscent WORD)
                              (\SFDescent WORD)
                              (\SFHeight WORD)
                              (ROTATION WORD)
                              (FBBOX SIGNEDWORD)
                              (FBBOY SIGNEDWORD)
                              (FBBDX SIGNEDWORD)
                              (FBBDY SIGNEDWORD)
                              (\SFLKerns POINTER)
                              (\SFRWidths POINTER)
                              (FONTDEVICESPEC POINTER)
                              (OTHERDEVICEFONTPROPS POINTER)
                              (FONTSCALE POINTER)
                              (\SFFACECODE BITS 8)
                              (FONTAVGCHARWIDTH WORD)
                              (FONTIMAGEWIDTHS POINTER)
                              (FONTCHARSETVECTOR POINTER)
                              (FONTEXTRAFIELD2 POINTER)))

(DATATYPE CHARSETINFO (WIDTHS OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD)
                                 (CHARSETDESCENT WORD)
                                 LEFTKERN))
)

(RPAQ? \FONTSINCORE )

(RPAQ? \DEFAULTDEVICEFONTS )

(RPAQ? \UNITWIDTHSVECTOR )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\UNITWIDTHSVECTOR)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ NORUNCODE 255)


(CONSTANTS (NORUNCODE 255))
)
(* "FOLLOWING DEFINITIONS EXPORTED")
(DEFOPTIMIZER FONTPROP (&REST ARGS)
                           (SELECTQ (AND (EQ (CAADR ARGS)
                                             'QUOTE)
                                         (CADADR ARGS))
                               (ASCENT (LIST 'FONTASCENT (CAR ARGS)))
                               (DESCENT (LIST 'FONTDESCENT (CAR ARGS)))
                               (HEIGHT (LIST 'FONTHEIGHT (CAR ARGS)))
                               'IGNOREMACRO))

(* "END EXPORTED DEFINITIONS")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE

(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
                         DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))

(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
                              (FONTFAMILY POINTER)
                              (FONTSIZE POINTER)
                              (FONTFACE POINTER)
                              (\SFAscent WORD)
                              (\SFDescent WORD)
                              (\SFHeight WORD)
                              (ROTATION WORD)
                              (FBBOX SIGNEDWORD)
                              (FBBOY SIGNEDWORD)
                              (FBBDX SIGNEDWORD)
                              (FBBDY SIGNEDWORD)
                              (\SFLKerns POINTER)
                              (\SFRWidths POINTER)
                              (FONTDEVICESPEC POINTER)       (* ; 
      "Holds the spec by which the font is known to the printing device, if coercion has been done")
                              (OTHERDEVICEFONTPROPS POINTER) (* ; 
                                               "For individual devices to hang special information")
                              (FONTSCALE POINTER)
                              (\SFFACECODE BITS 8)
                              (FONTAVGCHARWIDTH WORD)        (* ; 
                          "Set in FONTCREATE, used to fix up the linelength when DSPFONT is called")
                              (FONTIMAGEWIDTHS POINTER)      (* ; "This is the image width, as opposed to the advanced width;  initial hack for accents, kerning.  Fields is referenced by FONTCREATE.")
                              (FONTCHARSETVECTOR POINTER)    (* ; "A 256-pointer block, with one pointer per 'character set' --each group of 256 character codes.  Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset.")
                              (FONTEXTRAFIELD2 POINTER))
                             FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR))

(RECORD FONTFACE (WEIGHT SLOPE EXPANSION)
                     [ACCESSFNS ((COLOR (CDDDR DATUM)
                                        (RPLACD (CDDR DATUM)
                                               NEWVALUE))
                                 (BACKCOLOR [COND
                                               ((CDDDR DATUM)
                                                (CAR (CDDDR DATUM]
                                        (PROGN [COND
                                                  ((NULL (CDDDR DATUM))
                                                   (RPLACD (CDDR DATUM)
                                                          (LIST NIL NIL]
                                               (RPLACA (CDDDR DATUM)
                                                      NEWVALUE)))
                                 (FORECOLOR [COND
                                               ((CDDDR DATUM)
                                                (CADR (CDDDR DATUM]
                                        (PROGN [COND
                                                  ((NULL (CDDDR DATUM))
                                                   (RPLACD (CDDR DATUM)
                                                          (LIST NIL NIL]
                                               (RPLACA (CDR (CDDDR DATUM))
                                                      NEWVALUE]
                     WEIGHT _ 'MEDIUM SLOPE _ 'REGULAR EXPANSION _ 'REGULAR (TYPE? LISTP))

(DATATYPE CHARSETINFO (WIDTHS                            (* ; "The advance-width of each character, an array indexed by charcode.  Usually the same as the imagewidth, but can differ for accents, kerns kerns.  This is what should be used for stringwidth calculations.")
                                 OFFSETS                     (* ; 
                            "Offset of each character into the image bitmap;  X value of left edge")
                                 IMAGEWIDTHS                 (* ; 
                         "imagewidths is not automagically allocated since it is not always needed")
                                 CHARSETBITMAP               (* ; 
                                       "Bitmap containing the character images, indexed by OFFSETS")
                                 YWIDTHS
                                 (CHARSETASCENT WORD)        (* ; 
                                                    "Max ascent for all characters in this CHARSET")
                                 (CHARSETDESCENT WORD)       (* ; 
                                                   "Max descent for all characters in this CHARSET")
                                 LEFTKERN)
                          WIDTHS _ (\CREATECSINFOELEMENT)
                          OFFSETS _ (\CREATECSINFOELEMENT))
)

(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
       '((FONTCLASS 0 (BITS . 7))
         (FONTCLASS 2 POINTER)
         (FONTCLASS 4 POINTER)
         (FONTCLASS 6 POINTER)
         (FONTCLASS 8 POINTER)
         (FONTCLASS 10 POINTER))
       '12)

(/DECLAREDATATYPE 'FONTDESCRIPTOR
       '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD 
               SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 2 POINTER)
         (FONTDESCRIPTOR 4 POINTER)
         (FONTDESCRIPTOR 6 POINTER)
         (FONTDESCRIPTOR 8 (BITS . 15))
         (FONTDESCRIPTOR 9 (BITS . 15))
         (FONTDESCRIPTOR 10 (BITS . 15))
         (FONTDESCRIPTOR 11 (BITS . 15))
         (FONTDESCRIPTOR 12 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 13 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 14 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 15 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 16 POINTER)
         (FONTDESCRIPTOR 18 POINTER)
         (FONTDESCRIPTOR 20 POINTER)
         (FONTDESCRIPTOR 22 POINTER)
         (FONTDESCRIPTOR 24 POINTER)
         (FONTDESCRIPTOR 26 (BITS . 7))
         (FONTDESCRIPTOR 27 (BITS . 15))
         (FONTDESCRIPTOR 28 POINTER)
         (FONTDESCRIPTOR 30 POINTER)
         (FONTDESCRIPTOR 32 POINTER))
       '34)

(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)
       '((CHARSETINFO 0 POINTER)
         (CHARSETINFO 2 POINTER)
         (CHARSETINFO 4 POINTER)
         (CHARSETINFO 6 POINTER)
         (CHARSETINFO 8 POINTER)
         (CHARSETINFO 10 (BITS . 15))
         (CHARSETINFO 11 (BITS . 15))
         (CHARSETINFO 12 POINTER))
       '14)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS FONTASCENT  MACRO
   ((FONTSPEC)
    (ffetch \SFAscent of (\GETFONTDESC FONTSPEC))))

(PUTPROPS FONTDESCENT  MACRO
   ((FONTSPEC)
    (ffetch \SFDescent of (\GETFONTDESC FONTSPEC))))

(PUTPROPS FONTHEIGHT  MACRO
   ((FONTSPEC)
    (ffetch \SFHeight of (\GETFONTDESC FONTSPEC))))

(PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE)
                                      (\GETBASE OFFSETSBLOCK CHAR8CODE)))

(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET)
                                      (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET)))

(PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE)
                                     (\GETBASE WIDTHSBLOCK CHAR8CODE)))

(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
                                     (\PUTBASE WIDTHSBLOCK INDEX WIDTH)))

(PUTPROPS \FGETCHARWIDTH  MACRO
   (OPENLAMBDA (FONTDESC CHARCODE)
     (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                FONTDESC))
            (\CHAR8CODE CHARCODE))))

(PUTPROPS \FSETCHARWIDTH  MACRO
   (OPENLAMBDA (FONTDESC CHARCODE WIDTH)
     (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                FONTDESC))
            (\CHAR8CODE CHARCODE)
            WIDTH)))

(PUTPROPS \FGETIMAGEWIDTH  MACRO
   ((IMAGEWIDTHSBLOCK CHAR8CODE)
    (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE)))

(PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
                                          (\PUTBASE WIDTHSBLOCK INDEX WIDTH)))

(PUTPROPS \GETCHARSETINFO  MACRO
   ((CHARSET FONTDESC NOSLUG?)

    (* ;; "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC.  If NIL, then creates the required charset.")

    (* ;; 
  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")

    (OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC)
               (UNFOLD CHARSET 2))
        (\CREATECHARSET CHARSET FONTDESC NOSLUG?))))

(PUTPROPS \CREATECSINFOELEMENT  MACRO
   (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3)
                            WORDSPERCELL))))

(PUTPROPS \CREATEFONTCHARSETVECTOR  MACRO
   (NIL                                                      (* ; 
                                                  "Allocates a block for the character set records")
        (\ALLOCBLOCK (ADD1 \MAXCHARSET)
               T)))
)

(DEFMACRO \CREATEKERNELEMENT ()
   `(CL:MAKE-ARRAY (IPLUS \MAXTHINCHAR 3)
           :ELEMENT-TYPE
           '(SIGNED-BYTE 16)
           :INITIAL-ELEMENT 0))

(DEFMACRO \FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE)
   `(CL:SETF (CL:AREF ,LEFTKERNBLOCK ,INDEX)
           ,KERNVALUE))

(DEFMACRO \FGETLEFTKERN (LEFTKERNBLOCK CHAR8CODE)
   `(CL:AREF ,LEFTKERNBLOCK ,CHAR8CODE))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAXNSCHAR 65535)


(CONSTANTS (\MAXNSCHAR 65535))
)

(* "END EXPORTED DEFINITIONS")

)



(* ; "NS Character specific code")

(DEFINEQ

(\CREATECHARSET
  [LAMBDA (CHARSET FONT NOSLUG?)                         (* ; "Edited  8-May-93 23:42 by rmk:")
                                                             (* ; "Edited  4-Dec-92 11:43 by jds")

    (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR")
                                                             (* ; 
  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")
    (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES))
    (AND (IGREATERP CHARSET \MAXCHARSET)
         (\ILLEGAL.ARG CHARSET))
    (PROG [CSINFO (CREATEFN (COND
                               ((FMEMB (FONTPROP FONT 'DEVICE)
                                       \DISPLAYSTREAMTYPES)
                                (FUNCTION \CREATECHARSET.DISPLAY))
                               (T (CADR (ASSOC 'CREATECHARSET (CDR (ASSOC (FONTPROP FONT
                                                                                 'DEVICE)
                                                                          IMAGESTREAMTYPES]

     (* ;; "Create a descriptor of info for that charset, and use it to fill things in.")

          (COND
             ([NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC)
                                                       (LIST CHARSET FONT NOSLUG?]
                                                             (* ; 
                                               "the create method returned NIL--NOSLUG? must be T.")
              (RETURN NIL)))
          (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT)
                                                            (SIGNED (fetch CHARSETASCENT
                                                                       of CSINFO)
                                                                   16)))
          (replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT)
                                                             (SIGNED (ffetch CHARSETDESCENT
                                                                        of CSINFO)
                                                                    16)))
          (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent of FONT)
                                                             (ffetch \SFDescent of FONT)))
                                                             (* ; 
                              "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")
          (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
                         CHARSET CSINFO])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS 
       CHARSETERRORFLG)
)

(RPAQ? DISPLAYFONTCOERCIONS NIL)

(RPAQ? MISSINGCHARSETDISPLAYFONTCOERCIONS
       '(((GACHA)
          (TERMINAL))
         ((MODERN)
          (CLASSIC))
         ((TIMESROMAN)
          (CLASSIC))
         ((HELVETICA)
          (MODERN))
         ((TERMINAL 6)
          (MODERN 6))
         ((TERMINAL 8)
          (MODERN 8))
         ((TERMINAL 10)
          (MODERN 10))
         ((TERMINAL 12)
          (MODERN 12))))

(RPAQ? MISSINGDISPLAYFONTCOERCIONS '(((GACHA)
                                          (TERMINAL))
                                         ((MODERN)
                                          (CLASSIC))
                                         ((TIMESROMAN)
                                          (CLASSIC))
                                         ((HELVETICA)
                                          (MODERN))))

(RPAQ? CHARSETERRORFLG NIL)

(RPAQ? \DEFAULTCHARSET 0)
(DEFINEQ

(\FONTRESETCHARWIDTHS
  [LAMBDA (CSINFO FIRSTCHAR LASTCHAR)                    (* AJB " 6-Dec-85 14:42")
                                                             (* ; 
                                                     "sets the widths array from the offsets array")
    (PROG ((mincharcode FIRSTCHAR)
           (maxcharcode LASTCHAR)
           (offsets (fetch (CHARSETINFO OFFSETS) of CSINFO))
           (widths (fetch (CHARSETINFO WIDTHS) of CSINFO))
           left right charoffset dummycharoffset dummycharwidth)
          (SETQ dummycharoffset (\FGETOFFSET offsets (ADD1 maxcharcode)))
          (SETQ dummycharwidth (IDIFFERENCE (\FGETOFFSET offsets (IPLUS maxcharcode 2))
                                      dummycharoffset))
          [for charcode from 0 to \MAXCHAR
             do (COND
                       ((OR (ILESSP charcode mincharcode)
                            (IGREATERP charcode maxcharcode))
                        (\FSETOFFSET offsets charcode dummycharoffset)
                        (\FSETWIDTH widths charcode dummycharwidth))
                       (T (SETQ left (\FGETWIDTH offsets charcode))
                          (SETQ right (\FGETWIDTH offsets (ADD1 charcode)))
                          (COND
                             ((EQ left right)
                              (\FSETOFFSET offsets charcode dummycharoffset)
                              (\FSETWIDTH widths charcode dummycharwidth))
                             (T (\FSETWIDTH widths charcode (IDIFFERENCE right left]
          (\FSETWIDTH widths (ADD1 \MAXCHAR)
                 dummycharwidth)
          (\FSETOFFSET offsets (ADD1 \MAXCHAR)
                 dummycharoffset])
)
(DECLARE%: DONTEVAL@LOAD 

(RPAQ? DISPLAYFONTEXTENSIONS 'DISPLAYFONT)

(RPAQ? DISPLAYFONTDIRECTORIES '({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ 
                                          {dsk}/usr/local/lde/fonts/display/publishing/))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \FGETCHARIMAGEWIDTH  MACRO
   (OPENLAMBDA (FONT CHARCODE)
     (\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                     FONT))
            (\CHAR8CODE CHARCODE))))

(PROGN (PUTPROPS \GETFONTDESC DMACRO [X (COND
                                                   ((CDR X)
                                                    (CONS '\COERCEFONTDESC X))
                                                   (T `(\DTEST ,(CAR X)
                                                              'FONTDESCRIPTOR])
       (PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC)))

(PUTPROPS \SETCHARSETINFO  MACRO
   ((CHARSETVECTOR CHARSET CSINFO)
    (\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2)
           CSINFO)))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)

(PUTPROPS FONT FILETYPE :FAKE-COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FONTCOPY)
)
(PUTPROPS FONT COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1994 1999))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (8608 18127 (CHARWIDTH 8618 . 9403) (CHARWIDTHY 9405 . 10775) (STRINGWIDTH 10777 . 11870
) (\CHARWIDTH.DISPLAY 11872 . 12285) (\STRINGWIDTH.DISPLAY 12287 . 12711) (\STRINGWIDTH.GENERIC 12713
 . 18125)) (18128 24510 (DEFAULTFONT 18138 . 19971) (FONTCLASS 19973 . 22135) (FONTCLASSUNPARSE 22137
 . 23036) (FONTCLASSCOMPONENT 23038 . 23547) (SETFONTCLASSCOMPONENT 23549 . 24508)) (25184 37916 (
FONTCREATE 25194 . 34461) (\FONT.SYMBOLMEMB 34463 . 34693) (\FONT.SYMBOLASSOC 34695 . 35853) (
\FONT.COMPARESYMBOL 35855 . 37914)) (37955 42579 (FONTASCENT 37965 . 38133) (FONTDESCENT 38135 . 38404
) (FONTHEIGHT 38406 . 38592) (FONTPROP 38594 . 42037) (\AVGCHARWIDTH 42039 . 42577)) (42626 55265 (
GETCHARBITMAP 42636 . 45526) (PUTCHARBITMAP 45528 . 53585) (MOVECHARBITMAP 53587 . 55263)) (55266 
140192 (FONTCOPY 55276 . 60584) (FONTSAVAILABLE 60586 . 65791) (FONTFILEFORMAT 65793 . 67417) (FONTP 
67419 . 67718) (FONTUNPARSE 67720 . 70284) (SETFONTDESCRIPTOR 70286 . 71995) (CHARCODEP 71997 . 72358)
 (EDITCHAR 72360 . 72789) (\STREAMCHARWIDTH 72791 . 76955) (\UNITWIDTHSVECTOR 76957 . 77320) (
\CREATEDISPLAYFONT 77322 . 78075) (\CREATECHARSET.DISPLAY 78077 . 80993) (\CREATE-REAL-CHARSET.DISPLAY
 80995 . 88286) (\BUILDSLUGCSINFO 88288 . 89731) (\SEARCHDISPLAYFONTFILES 89733 . 91666) (
\SEARCHFONTFILES 91668 . 94979) (\FINDFONTFILE 94981 . 96172) (\FONTSYMBOL 96174 . 96824) (
\DEVICESYMBOL 96826 . 97695) (\FONTFACE 97697 . 104887) (\FONTFACE.COLOR 104889 . 111809) (
\FONTFILENAME 111811 . 115226) (\FONTFILENAME.OLD 115228 . 118177) (\FONTFILENAME.NEW 118179 . 120436)
 (\FONTINFOFROMFILENAME 120438 . 123552) (\FONTINFOFROMFILENAME.OLD 123554 . 125831) (\GETFONTDESC 
125833 . 126224) (\COERCEFONTDESC 126226 . 131611) (\LOOKUPFONT 131613 . 132957) (\LOOKUPFONTSINCORE 
132959 . 135032) (\READDISPLAYFONTFILE 135034 . 140190)) (141096 158146 (\READSTRIKEFONTFILE 141106 . 
145634) (\SFMAKEBOLD 145636 . 148032) (\SFMAKEITALIC 148034 . 150937) (\SFMAKEROTATEDFONT 150939 . 
152340) (\SFROTATECSINFO 152342 . 152979) (\SFROTATEFONTCHARACTERS 152981 . 153361) (
\SFFIXOFFSETSAFTERROTATION 153363 . 155502) (\SFROTATECSINFOOFFSETS 155504 . 156773) (\SFMAKECOLOR 
156775 . 158144)) (158147 166458 (WRITESTRIKEFONTFILE 158157 . 162998) (STRIKECSINFO 163000 . 166456))
 (180718 183574 (\CREATECHARSET 180728 . 183572)) (184660 186412 (\FONTRESETCHARWIDTHS 184670 . 186410
)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 9-Feb-2021 11:39:44" {DSK}<home>larry>ilisp>medley>sources>FONT.;7 189150 

      changes to%:  (VARS FONTCOMS)

      previous date%: "28-Jun-99 16:29:49" {DSK}<home>larry>ilisp>medley>sources>FONT.;6)


(* ; "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1999, 
2021 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT FONTCOMS)

(RPAQQ FONTCOMS
       [
        (* ;; "font functions ")

        (FNS CHARWIDTH CHARWIDTHY STRINGWIDTH \CHARWIDTH.DISPLAY \STRINGWIDTH.DISPLAY 
             \STRINGWIDTH.GENERIC)
        (FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT)
        [COMS                                                (* ; 
                                                           "Until we pin down the exact interface")
              (P (MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT)
                 (MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT]
        [COMS                                                (* ; "MAPPING FOR DOS FILENAMES ")
              (INITVARS (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR)
                                                   (HELVETICA . HV)
                                                   (TIMESROMAND . TD)
                                                   (HELVETICAD . HD)
                                                   (MODERN . MD)
                                                   (CLASSIC . CL)
                                                   (GACHA . GC)
                                                   (TITAN . TI)
                                                   (LETTERGOTHIC . LG)
                                                   (BOLDPS . BP)
                                                   (TERMINAL . TM)
                                                   (CLASSICTHIN . CT)
                                                   (HIPPO . HP)
                                                   (LOGO . LG)
                                                   (MATH . MA)
                                                   (OLDENGLISH . OE)
                                                   (SYMBOL . SY]
        (COMS 
              (* ;; "Creation: ")

              (FNS FONTCREATE \FONT.SYMBOLMEMB \FONT.SYMBOLASSOC \FONT.COMPARESYMBOL))
        (COMS 
              (* ;; "Property extraction:")

              (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH))
        (COMS 
              (* ;; "Bitmap editing/manipulation:")

              (FNS GETCHARBITMAP PUTCHARBITMAP MOVECHARBITMAP))
        (FNS FONTCOPY FONTSAVAILABLE FONTFILEFORMAT FONTP FONTUNPARSE SETFONTDESCRIPTOR CHARCODEP 
             EDITCHAR \STREAMCHARWIDTH \UNITWIDTHSVECTOR \CREATEDISPLAYFONT \CREATECHARSET.DISPLAY 
             \CREATE-REAL-CHARSET.DISPLAY \BUILDSLUGCSINFO \SEARCHDISPLAYFONTFILES \SEARCHFONTFILES 
             \FINDFONTFILE \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR \FONTFILENAME 
             \FONTFILENAME.OLD \FONTFILENAME.NEW \FONTINFOFROMFILENAME \FONTINFOFROMFILENAME.OLD 
             \GETFONTDESC \COERCEFONTDESC \LOOKUPFONT \LOOKUPFONTSINCORE \READDISPLAYFONTFILE)
        (COMS 
              (* ;; "\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories.  That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places.  ")

              (ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE))
              (INITVARS (*USEOLDFONTDIRECTORIES* NIL))
              (GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)
              
              (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)")
)
        (COMS 
              (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)")

              (INITVARS (CACHEDISPLAYFONTS))
              (GLOBALVARS CACHEDISPLAYFONTS)
                                                             (* ; "STRIKE format file support")
              (FNS \READSTRIKEFONTFILE \SFMAKEBOLD \SFMAKEITALIC \SFMAKEROTATEDFONT \SFROTATECSINFO 
                   \SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION \SFROTATECSINFOOFFSETS 
                   \SFMAKECOLOR)
              (FNS WRITESTRIKEFONTFILE STRIKECSINFO))
        (INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
        (SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
        (INITVARS (\FONTSINCORE)
               (\DEFAULTDEVICEFONTS)
               (\UNITWIDTHSVECTOR))
        (GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\UNITWIDTHSVECTOR)))
        (CONSTANTS (NORUNCODE 255))
        (EXPORT (OPTIMIZERS FONTPROP))
        [DECLARE%: DONTCOPY
               (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO)
                      (MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET \FGETWIDTH 
                             \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH \FGETIMAGEWIDTH \FSETIMAGEWIDTH
                             \GETCHARSETINFO \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR)
                      (FUNCTIONS \CREATEKERNELEMENT \FSETLEFTKERN \FGETLEFTKERN)
                      (CONSTANTS (\MAXNSCHAR 65535]
        (COMS                                                (* ; "NS Character specific code")
              (FNS \CREATECHARSET)
              (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS 
                     MISSINGCHARSETDISPLAYFONTCOERCIONS CHARSETERRORFLG)
              (INITVARS (DISPLAYFONTCOERCIONS NIL)
                     [MISSINGCHARSETDISPLAYFONTCOERCIONS '(((GACHA)
                                                            (TERMINAL))
                                                           ((MODERN)
                                                            (CLASSIC))
                                                           ((TIMESROMAN)
                                                            (CLASSIC))
                                                           ((HELVETICA)
                                                            (MODERN))
                                                           ((TERMINAL 6)
                                                            (MODERN 6))
                                                           ((TERMINAL 8)
                                                            (MODERN 8))
                                                           ((TERMINAL 10)
                                                            (MODERN 10))
                                                           ((TERMINAL 12)
                                                            (MODERN 12]
                     [MISSINGDISPLAYFONTCOERCIONS '(((GACHA)
                                                     (TERMINAL))
                                                    ((MODERN)
                                                     (CLASSIC))
                                                    ((TIMESROMAN)
                                                     (CLASSIC))
                                                    ((HELVETICA)
                                                     (MODERN]
                     (CHARSETERRORFLG NIL)
                     (\DEFAULTCHARSET 0)))
        (FNS \FONTRESETCHARWIDTHS)
        [DECLARE%: DONTEVAL@LOAD (INITVARS (DISPLAYFONTEXTENSIONS 'DISPLAYFONT)
                                        (DISPLAYFONTDIRECTORIES '(
                                                      {DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/
                                                                  
                                                        {dsk}/usr/local/lde/fonts/display/publishing/
                                                                  ]
        (MACROS \FGETCHARIMAGEWIDTH \GETFONTDESC \SETCHARSETINFO)
        (LOCALVARS . T)
        (PROP FILETYPE FONT)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA FONTCOPY])



(* ;; "font functions ")

(DEFINEQ

(CHARWIDTH
  [LAMBDA (CHARCODE FONT)                                (* rmk%: "12-Apr-85 09:46")
                                                             (* ; 
                                              "gets the width of a character code in a font/stream")
    (OR (\CHARCODEP CHARCODE)
        (\ILLEGAL.ARG CHARCODE))
    (LET (TEMP)
         (COND
            ((type? FONTDESCRIPTOR FONT)
             (\FGETCHARWIDTH FONT CHARCODE))
            ((SETQ TEMP (\OUTSTREAMARG FONT T))              (* ; 
                                                     "NIL font goes thru here--primary output file")
             (IMAGEOP 'IMCHARWIDTH TEMP TEMP CHARCODE))
            (T (\FGETCHARWIDTH (FONTCREATE FONT)
                      CHARCODE])

(CHARWIDTHY
  [LAMBDA (CHARCODE FONT)                                (* edited%: "18-Mar-86 19:30")
                                                             (* ; 
                                 "Gets the Y-component of the width of a character code in a font.")
    (OR (\CHARCODEP CHARCODE)
        (\ILLEGAL.ARG CHARCODE))
    (LET (TEMP WY)
         (COND
            ((type? FONTDESCRIPTOR FONT)
             (SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                      FONT)))
             (COND
                ((FIXP WY))
                (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
                (T 0)))
            ((type? STREAM (SETQ TEMP (\OUTSTREAMARG FONT T)))
                                                             (* ; 
                                                     "NIL font goes thru here--primary output file")
             (IMAGEOP 'IMCHARWIDTHY TEMP TEMP CHARCODE))
            (T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                        (FONTCREATE FONT]
               (COND
                  ((FIXP WY))
                  (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
                  (T 0])

(STRINGWIDTH
  [LAMBDA (STR FONT FLG RDTBL)                           (* ; "Edited  8-Jan-88 14:41 by Snow")

    (* ;; "Returns the width of STR according to FONT")

    (LET (TEMP)

         (* ;; "Used in \MAPCHARS")

         (COND
            [(type? FONTDESCRIPTOR FONT)
             (\STRINGWIDTH.GENERIC STR FONT (AND FLG (\GTREADTABLE RDTBL))
                    (\FGETCHARWIDTH FONT (CHARCODE SPACE]
            [(AND FONT (SETQ TEMP (\OUTSTREAMARG FONT T)))   (* ; 
  "if you gave something for FONT, coerce it to a stream, and call the stringwidth function of it.")
             (IMAGEOP 'IMSTRINGWIDTH TEMP TEMP STR (AND FLG (\GTREADTABLE RDTBL]
            (T (SETQ TEMP (FONTCREATE (OR FONT DEFAULTFONT)))
                                                             (* ; "NIL font will pass thru here.  ie, defaultfont is used to do the stringwidth instead of the font of *standard-output*")
               (\STRINGWIDTH.GENERIC STR TEMP (AND FLG (\GTREADTABLE RDTBL))
                      (\FGETCHARWIDTH TEMP (CHARCODE SPACE])

(\CHARWIDTH.DISPLAY
  [LAMBDA (STREAM CHARCODE)                              (* rmk%: "12-Apr-85 09:42")
                                                             (* ; 
         "gets the width of a character code in a display stream.  Need to fix up for spacefactor.")
    (\FGETCHARWIDTH (ffetch (\DISPLAYDATA DDFONT) of (ffetch IMAGEDATA of STREAM))
           CHARCODE])

(\STRINGWIDTH.DISPLAY
  [LAMBDA (STREAM STR RDTBL)                             (* ; "Edited  3-Apr-87 12:07 by jop")

    (* ;; "Returns the width of for the current font/spacefactor in STREAM.")

    (LET ((DD (ffetch IMAGEDATA of STREAM)))
         (\STRINGWIDTH.GENERIC STR (ffetch (\DISPLAYDATA DDFONT) of DD)
                RDTBL
                (ffetch DDSPACEWIDTH of DD])

(\STRINGWIDTH.GENERIC
  [LAMBDA (STR FONT RDTBL SPACEWIDTH)                    (* ; "Edited  3-Apr-87 13:47 by jop")

    (* ;; "Returns the width of STR with SPACEWIDTH for the width of spaces.  RDTBL has already been coerced, so no FLG is needed ")

    (* ;; "This is cloned in \STRINGWIDTH.HCPYDISPLAYAUX by straight substitution -- (PUTDEF (QUOTE \STRINGWIDTH.HCPYDISPLAYAUX) (QUOTE FNS) (SUBLIS (QUOTE ((WIDTHS  . IMAGEWIDTHS) (\FGETWIDTH  . \FGETIMAGEWIDTH) (\FGETCHARWIDTH  . \FGETCHARIMAGEWIDTH))) (GETDEF (QUOTE \STRINGWIDTH.GENERIC))))")

    (* ;; "\MAPPNAME uses WIDTHSBASE CSET TOTALWIDTH FONT SPACEWIDTH free, so these become special in bytecompiler")

    (PROG NIL
          [COND
             [(LITATOM STR)
              (if RDTBL
                  then (GO SLOW)
                else (RETURN (for C WIDTHSBASE CSET inatom STR
                                    sum [COND
                                               ((NEQ CSET (\CHARSET C))
                                                (SETQ CSET (\CHARSET C))
                                                (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
                                                                    of (\GETCHARSETINFO CSET FONT
                                                                                  ]
                                          (COND
                                             ((EQ C (CHARCODE SPACE))
                                              SPACEWIDTH)
                                             (T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C]
             ((STRINGP STR)
              (RETURN
               (LET ((TOTAL 0)
                     ESC ESCWIDTH WIDTHSBASE CSET)
                    [COND
                       (RDTBL                                (* ; 
                                                     "Count delimiting quotes and internal escapes")
                              (SETQ TOTAL (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %"))
                                                 2))
                              (SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL))
                              (SETQ ESCWIDTH (\FGETCHARWIDTH FONT ESC]
                    [for C instring STR
                       do [COND
                                 ((NEQ (\CHARSET C)
                                       CSET)                 (* ; 
                                                     "Get the widths vector for this character set")
                                  (SETQ CSET (\CHARSET C))
                                  (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
                                                      of (\GETCHARSETINFO CSET FONT]
                             (add TOTAL (COND
                                               ((EQ C (CHARCODE SPACE))
                                                SPACEWIDTH)
                                               (T (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C))
                                                         (COND
                                                            ((AND RDTBL (OR (EQ C (CHARCODE %"))
                                                                            (EQ C ESC)))
                                                             (* ; "String char must be escaped")
                                                             ESCWIDTH)
                                                            (T 0]
                    TOTAL]
      SLOW
                                                             (* ; "Do the general case here")
          (RETURN (LET ((TOTALWIDTH 0)
                        WIDTHSBASE CSET (FONT FONT)
                        (SPACEWIDTH SPACEWIDTH))
                       (DECLARE (SPECVARS TOTALWIDTH WIDTHSBASE CSET FONT SPACEWIDTH))
                       (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CC)
                                              (add TOTALWIDTH (COND
                                                                     ((EQ CC (CHARCODE SPACE))
                                                                      SPACEWIDTH)
                                                                     ((EQ CSET (\CHARSET CC))
                                                                      (\FGETWIDTH WIDTHSBASE
                                                                             (\CHAR8CODE CC)))
                                                                     (T (SETQ CSET (\CHARSET CC))
                                                                        (SETQ WIDTHSBASE
                                                                         (ffetch (CHARSETINFO
                                                                                      WIDTHS)
                                                                            of (\GETCHARSETINFO
                                                                                    CSET FONT)))
                                                                        (\FGETWIDTH WIDTHSBASE
                                                                               (\CHAR8CODE CC]
                              STR RDTBL RDTBL *PRINT-LEVEL* *PRINT-LENGTH*)
                       TOTALWIDTH])
)
(DEFINEQ

(DEFAULTFONT
  [LAMBDA (DEVICE FONT NOERRORFLG)                       (* ; "Edited 28-Jul-88 13:15 by rmk:")
                                                             (* ; "Edited 24-Mar-87 14:41 by FS")

    (* ;; "Returns the default font for an image type.  Really only needed to guarantee validity of the display default font for system critical routines, in case the user has smashed the variable DEFAULTFONT.  Note that SETFONTCLASSCOMPONENT and FONTCLASS guarantee that the display component is either NIL or a fontdescriptor.")

    (* ;; "FS- If FONT provided set the font descriptor.  Do not bother to check if NOERRORFLG is NEW. (old code had (AND FONT (EQ NOERRORFLG 'NEW)))")

    [OR (type? FONTCLASS DEFAULTFONT)
        (SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT]
    (if FONT
        then 

              (* ;; "FS- Not clear the fontclass should be smashed, perhaps instead should make a new FONTCLASS and then rebind DEFAULTFONT.  Leaving alone for histerical reasons")

              (SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE FONT)
      else 

            (* ;; "The code below (not mine!) is messy but is correct (unless weirdness pops up because of deep recursion).")

            (COND
               ((\COERCEFONTDESC DEFAULTFONT DEVICE T))
               (NOERRORFLG NIL)
               ((EQ (\DEVICESYMBOL DEVICE T)
                    'DISPLAY)

                (* ;; "If getting for the display and the font can't be found perhaps because of garbage in the display field of the DEFAULTFONTCLASS, then the system-guaranteed displayfont.  Otherwise, cause the error in the re-coercion.  Can never tell when DEVICE is just a symbol.")

                \GUARANTEEDDISPLAYFONT)
               ((\COERCEFONTDESC DEFAULTFONT DEVICE])

(FONTCLASS
  [LAMBDA (NAME FONTLIST CREATEFORDEVICES)               (* jds " 9-Sep-86 18:49")

    (* ;; "This builds D style font classes, which are datatypes containing entries for the various known devices.")

    (* ;; "Don't actually set up the for devices not inside CREATEFORDEVICES on the theory that any given user presumably doesn't want all the fonts for all the devices.  We wait until he actually asks for the font or the fontmaparray, at which point we note that the fields don't contain FD's, so we then apply FONTCREATE.  The actual coercion and caching is done inside \COERCEFONTDESC.  However, so as to prevent display crashes, if a display component is specified, we always do the fontcreate before we stick it in.")

    (PROG (F FC FL)
          (SETQ FL FONTLIST)
          [SETQ FC (create FONTCLASS
                          FONTCLASSNAME _ NAME
                          PRETTYFONT# _ (OR (FIXP (pop FL))
                                            1)
                          DISPLAYFD _ (AND (SETQ F (pop FL))
                                           (FONTCREATE F NIL NIL NIL 'DISPLAY))
                          PRESSFD _ (pop FL)
                          INTERPRESSFD _ (pop FL)
                          OTHERFDS _ (for FSPEC in FL
                                        collect (OR (AND (LISTP FSPEC)
                                                             (ATOM (CAR FSPEC))
                                                             (CAR FSPEC))
                                                        (ERROR "illegal font class specification"
                                                               (LIST NAME FONTLIST))) 
                                                             (* ; 
                                     "Copy the alist entry so it can be smashed in \COERCEFONTDESC")
                                              (CONS (CAR FSPEC)
                                                    (CAR (LISTP (CDR FSPEC]
          (for D inside CREATEFORDEVICES do (FONTCREATE FC NIL NIL NIL D))
          (RETURN FC])

(FONTCLASSUNPARSE
  [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG)         (* jds "24-Jan-86 11:58")
                                                             (* ; 
                                "Given a font class, unparse it to a form that might be reparsable")
    (APPEND (LIST (fetch (FONTCLASS FONTCLASSNAME) of FONTCLASS)
                  (fetch (FONTCLASS PRETTYFONT#) of FONTCLASS)
                  (FONTUNPARSE (ffetch (FONTCLASS DISPLAYFD) of FONTCLASS))
                  (FONTUNPARSE (ffetch (FONTCLASS PRESSFD) of FONTCLASS))
                  (FONTUNPARSE (ffetch (FONTCLASS INTERPRESSFD) of FONTCLASS)))
           (for X in (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
              collect (LIST (CAR X)
                                (FONTUNPARSE (CDR X])

(FONTCLASSCOMPONENT
  [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG)         (* rmk%: "14-Sep-84 19:34")
    (PROG1 (FONTCREATE FONTCLASS NIL NIL NIL DEVICE NOERRORFLG)
                                                             (* ; 
                    "This works its way down to \COERCEFONTDESC, where it needs to be done quickly")
        (AND FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL DEVICE NOERRORFLG))
             (SETFONTCLASSCOMPONENT FONTCLASS DEVICE FONT)))])

(SETFONTCLASSCOMPONENT
  [LAMBDA (FONTCLASS DEVICE FONT)                    (* ; "Edited 29-Aug-91 12:20 by jds")
    (PROG ((NEWFONT (FONTCREATE FONT NIL NIL NIL DEVICE)))

     (* ;; "replaces will barf if FONTCLASS is not a fontclass")

          (SELECTQ (SETQ DEVICE (FONTPROP NEWFONT 'DEVICE))
              (DISPLAY (replace (FONTCLASS DISPLAYFD) of FONTCLASS with NEWFONT))
              (INTERPRESS (replace (FONTCLASS INTERPRESSFD) of FONTCLASS with NEWFONT
                                 ))
              (PRESS (replace (FONTCLASS PRESSFD) of FONTCLASS with NEWFONT))
              (RPLACD [OR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of FONTCLASS))
                          (CAR (push (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
                                      (CONS DEVICE]
                     NEWFONT))
          (RETURN NEWFONT])
)



(* ; "Until we pin down the exact interface")


(MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT)

(MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT)



(* ; "MAPPING FOR DOS FILENAMES ")


(RPAQ? *DISPLAY-FONT-NAME-MAP*
       '((TIMESROMAN . TR)
         (HELVETICA . HV)
         (TIMESROMAND . TD)
         (HELVETICAD . HD)
         (MODERN . MD)
         (CLASSIC . CL)
         (GACHA . GC)
         (TITAN . TI)
         (LETTERGOTHIC . LG)
         (BOLDPS . BP)
         (TERMINAL . TM)
         (CLASSICTHIN . CT)
         (HIPPO . HP)
         (LOGO . LG)
         (MATH . MA)
         (OLDENGLISH . OE)
         (SYMBOL . SY)))



(* ;; "Creation: ")

(DEFINEQ

(FONTCREATE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)
                                                             (* ; "Edited 10-Oct-88 09:53 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:43 by rmk:")
                                                             (* ; "Edited 10-Nov-87 18:08 by FS")

    (* ;; "Create a font descriptor for the specified font.  If NOERRORFLG, return NIL if the font doesn't exist;  otherwise cause an error.")

    (* ;; "Cache and fonts.widths traffic in uppercase only.")

    (* ;; "character set is optional and defaults to \DEFAULTCHARSET (0 in our world)")

    (DECLARE (GLOBALVARS IMAGESTREAMTYPES \DEFAULTCHARSET))
    (PROG (FONTX (CHSET (OR CHARSET \DEFAULTCHARSET)))
          (RETURN (COND
                     ((LISTP FAMILY)
                      (SELECTQ (CAR FAMILY)
                          (FONT (SETQ FONTX (CDR FAMILY)))
                          (CLASS (COND
                                    ((LITATOM (CADR FAMILY)) (* ; "litatom class name")
                                     (RETURN (FONTCLASS (CADR FAMILY)
                                                    (CDDR FAMILY)
                                                    DEVICE)))
                                    (T                       (* ; 
                     "Allows for a font named CLASS--distinguished cause its size is not a litatom")
                                       (SETQ FONTX FAMILY))))
                          (SETQ FONTX FAMILY))
                      (FONTCREATE (CAR FONTX)
                             (OR (CADR FONTX)
                                 SIZE)
                             (OR (CADDR FONTX)
                                 FACE)
                             (OR (CADDDR FONTX)
                                 ROTATION)
                             (OR (CADR (CDDDR FONTX))
                                 DEVICE)
                             NOERRORFLG CHSET))
                     ([SETQ FONTX (COND
                                     ((type? FONTDESCRIPTOR FAMILY)
                                      FAMILY)
                                     ((NULL FAMILY)
                                      (DEFAULTFONT DEVICE))
                                     ((type? FONTCLASS FAMILY)

                                 (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.  Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.")

                                      (\COERCEFONTDESC FAMILY DEVICE NOERRORFLG))
                                     ((OR (IMAGESTREAMP FAMILY)
                                          (type? WINDOW FAMILY))
                                      (DSPFONT NIL FAMILY]

                      (* ;; 
                 "FAMILY was a spec for a font descriptor, use it and extend it by the other args.")

                      (COND
                         ((OR SIZE FACE ROTATION DEVICE)
                          (FONTCREATE (FONTPROP FONTX 'FAMILY)
                                 (OR SIZE (FONTPROP FONTX 'SIZE))
                                 (OR FACE (FONTPROP FONTX 'FACE))
                                 (OR ROTATION (FONTPROP FONTX 'ROTATION))
                                 (OR DEVICE (FONTPROP FONTX 'DEVICE))
                                 NOERRORFLG))
                         (T FONTX)))
                     (T (PROG (FONTFACE (DEV DEVICE))
                          RETRY
                              [OR (LITATOM FAMILY)
                                  (COND
                                     (NOERRORFLG (RETURN))
                                     (T (LISPERROR "ARG NOT LITATOM" FAMILY T]
                              [OR (AND (FIXP SIZE)
                                       (IGREATERP SIZE 0))
                                  (COND
                                     (NOERRORFLG (RETURN NIL))
                                     (T (\ILLEGAL.ARG SIZE]
                              (COND
                                 ((NULL ROTATION)
                                  (SETQ ROTATION 0))
                                 ((AND (FIXP ROTATION)
                                       (IGEQ ROTATION 0)))
                                 (NOERRORFLG (RETURN NIL))
                                 (T (\ILLEGAL.ARG ROTATION)))
                              [SETQ DEV (COND
                                           ((NULL DEVICE)
                                            'DISPLAY)
                                           ((AND (LITATOM DEVICE)
                                                 (NEQ DEVICE T))
                                                             (* ; 
"Maybe wrong case or package, but we bet it's OK and defer  expensive coercion until we've failed.")
                                            DEV)
                                           ((SETQ DEV (\GETSTREAM DEVICE 'OUTPUT T))
                                                             (* ; 
                                                           "T coerces here to primary output")
                                            (fetch (IMAGEOPS IMFONTCREATE)
                                               of (fetch (STREAM IMAGEOPS) of DEV)))
                                           ((STRINGP DEVICE)
                                            (MKATOM (U-CASE DEVICE)))
                                           (NOERRORFLG (RETURN NIL))
                                           (T (\ILLEGAL.ARG DEVICE]
                                                             (* ; "DEV is now guanteed litatom")
                          NEWDEV
                                                             (* ; 
                                                  "Check after device since it is device-dependent")
                              (SETQ FONTFACE (OR (\FONTFACE FACE NOERRORFLG DEV)
                                                 (RETURN NIL)))
                                                             (* ; "Don't truly coerce to \FONTSYMBOL or \DEVICESYMBOL until we've had a shot at the font cache, since re-interning atoms is so expensive")
                              [RETURN (COND
                                         ((\LOOKUPFONT FAMILY SIZE FONTFACE ROTATION DEV))
                                         [(SETQ FONTX (CDR (ASSOC DEV IMAGESTREAMTYPES)))

                                 (* ;; "Device is valid, font just doesn't exist.   FONTFACE, DEV already canonical.  Make FAMILY so, so that each imagestream type doesn't have to.")

                                          (SETQ FAMILY (\FONTSYMBOL FAMILY))
                                          (COND
                                             ((SETQ FONTX (APPLY* (OR (CADR (ASSOC 'FONTCREATE FONTX)
                                                                            )
                                                                      (FUNCTION NILL))
                                                                 FAMILY SIZE FONTFACE ROTATION DEV 
                                                                 CHSET))

                                      (* ;; "default creation case.  Use fontcreate method from device, build a fontdescriptor and use setfontdescriptor to install it.")

                                 (* ;; "OBSOLETEd by the CHARSETINFO code (OR (ffetch FONTIMAGEWIDTHS of FONTX) (freplace FONTIMAGEWIDTHS of FONTX with (ffetch \SFWidths of FONTX)))")

                                              (* ;; 
             "the widths fields in the fontdescriptor are obsolete, and shoudln't be updated here.")

                                           (* ;; "We should probably force all device implementations to obey these conventions, then remove these generic updates")

                                              (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH)
                                                 of FONTX with (\AVGCHARWIDTH FONTX))
                                              (SETFONTDESCRIPTOR FAMILY SIZE FONTFACE ROTATION 
                                                     DEV FONTX))
                                             (T (GO NOTFOUND]
                                         ((NEQ DEV (SETQ DEV (U-CASE DEV)))

                                 (* ;; "We didn't recognize the device, so check to see whether coercion to U-CASE IL changes anything.  Could be slow, but we're heading for an error.")

                                          (GO NEWDEV))
                                         (T (GO NOTFOUND]
                          NOTFOUND
                              (COND
                                 (NOERRORFLG (RETURN NIL))
                                 (T (ERROR "FONT NOT FOUND (coerced to)"
                                           (LIST FAMILY SIZE FONTFACE ROTATION DEV))
                                    (GO RETRY])

(\FONT.SYMBOLMEMB
  [LAMBDA (USERINPUT LIST)                               (* ; "Edited  7-Feb-89 15:47 by jds")
    (for X on LIST when (\FONT.COMPARESYMBOL USERINPUT (CAR X))
       do (RETURN X])

(\FONT.SYMBOLASSOC
  [LAMBDA (USERINPUT LIST)                               (* ; "Edited 28-Jul-88 16:56 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:15 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:03 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:16 by rmk:")
    (for X FIRSTC (NC _ (NCHARS USERINPUT)) in LIST
       first (SETQ FIRSTC (CHCON1 USERINPUT))
             [if (AND (IGEQ FIRSTC (CHARCODE a))
                          (ILEQ FIRSTC (CHARCODE z)))
                 then (SETQ FIRSTC (IDIFFERENCE FIRSTC (IDIFFERENCE (CHARCODE a)
                                                                  (CHARCODE A]
       when (AND (EQ NC (NCHARS (CAR X)))
                     (EQ FIRSTC (CHCON1 (CAR X)))
                     (\FONT.COMPARESYMBOL USERINPUT (CAR X)
                            NC FIRSTC)) do (RETURN X])

(\FONT.COMPARESYMBOL
  [LAMBDA (USERINPUT KEY INPUTNC INPUTFIRSTC) (* ; 
                                                "Edited 24-May-93 16:45 by sybalsky:mv:envos")

    (* ;; " An open coded case- and package-insensitive comparison of atom pnames, assuming that KEY is already upper-case but USERINPUT may not be.  Maybe there is a simple function that does this.")

    (* ;; "INPUTNC and INPUTFIRSTC can be passed in if they are common to lots of calls")

    (COND
       ((AND (LITATOM USERINPUT)
             (EQ [CL:AREF *PACKAGE-FROM-INDEX* (fetch (PNAMECELL PACKAGEINDEX)
                                                  of (PROGN (\PNAMECELL USERINPUT]
                 *INTERLISP-PACKAGE*))

        (* ;; "If the user's symbol is in the IL package (which is where all the KEYs are), we can use EQ, which is MUCH faster.")

        (OR (EQ USERINPUT KEY)
            (EQ (U-CASE USERINPUT)
                KEY)))
       (T 
          (* ;; "Otherwise, we do the comparison character by character.")

          (AND (EQ (OR INPUTNC (NCHARS USERINPUT))
                   (NCHARS KEY))
               [COND
                  (INPUTFIRSTC (EQ INPUTFIRSTC (CHCON1 KEY)))
                  ((EQ (SETQ INPUTFIRSTC (CHCON1 USERINPUT))
                       (CHCON1 KEY)))
                  ((AND (IGEQ INPUTFIRSTC (CHARCODE a))
                        (ILEQ INPUTFIRSTC (CHARCODE z)))
                   (EQ (IDIFFERENCE INPUTFIRSTC (IDIFFERENCE (CHARCODE a)
                                                       (CHARCODE A)))
                       (CHCON1 KEY]
               (for CHAR1 inatom USERINPUT as CHAR2 inatom KEY
                  always (OR (EQ CHAR1 CHAR2)
                                 (AND (IGEQ CHAR1 (CHARCODE a))
                                      (ILEQ CHAR1 (CHARCODE z))
                                      (EQ CHAR2 (IPLUS CHAR1 (CONSTANT (IDIFFERENCE (CHARCODE A)
                                                                              (CHARCODE a])
)



(* ;; "Property extraction:")

(DEFINEQ

(FONTASCENT
  [LAMBDA (FONTSPEC)                                     (* lmm "19-NOV-82 00:23")
    (ffetch \SFAscent of (\GETFONTDESC FONTSPEC])

(FONTDESCENT
  [LAMBDA (FONTSPEC)                                     (* lmm "19-NOV-82 00:24")
                                                             (* ; "See comment in FONTASCENT")
    (ffetch \SFDescent of (\GETFONTDESC FONTSPEC])

(FONTHEIGHT
  [LAMBDA (FONTSPEC)                                     (* kbr%: " 9-Jan-86 18:29")
    (fetch (FONTDESCRIPTOR \SFHeight) of (\GETFONTDESC FONTSPEC])

(FONTPROP
  [LAMBDA (FONT PROP)                                    (* kbr%: "13-May-85 22:36")
    (SETQ FONT (\GETFONTDESC FONT))
    (SELECTQ PROP
        (HEIGHT (ffetch \SFHeight of FONT))
        (ASCENT (ffetch \SFAscent of FONT))
        (DESCENT (ffetch \SFDescent of FONT))
        (FAMILY (ffetch FONTFAMILY of FONT))
        (SIZE (ffetch FONTSIZE of FONT))
        (FACE (COPY (ffetch FONTFACE of FONT)))
        (WEIGHT (ffetch WEIGHT of (ffetch FONTFACE of FONT)))
        (SLOPE (ffetch SLOPE of (ffetch FONTFACE of FONT)))
        (EXPANSION (ffetch EXPANSION of (ffetch FONTFACE of FONT)))
        (FORECOLOR (ffetch FORECOLOR of (ffetch FONTFACE of FONT)))
        (BACKCOLOR (ffetch BACKCOLOR of (ffetch FONTFACE of FONT)))
        (ROTATION (ffetch ROTATION of FONT))
        (DEVICE (ffetch FONTDEVICE of FONT))
        (SPEC (LIST (ffetch FONTFAMILY of FONT)
                    (ffetch FONTSIZE of FONT)
                    (COPY (ffetch FONTFACE of FONT))
                    (ffetch ROTATION of FONT)
                    (ffetch FONTDEVICE of FONT)))
        (DEVICESPEC                                          (* ; 
                  "DEVICE fields are for communicating coercions to the particular printing device")
                    [COND
                       ((ffetch FONTDEVICESPEC of FONT)
                        (COPY (ffetch FONTDEVICESPEC of FONT)))
                       (T (FONTPROP FONT 'SPEC])
        (DEVICEFACE [COPY (COND
                             ((ffetch FONTDEVICESPEC of FONT)
                              (CADDR (ffetch FONTDEVICESPEC of FONT)))
                             (T (ffetch FONTFACE of FONT])
        (DEVICESLOPE [fetch SLOPE of (COND
                                                ((ffetch FONTDEVICESPEC of FONT)
                                                 (CADDR (ffetch FONTDEVICESPEC of FONT)))
                                                (T (ffetch FONTFACE of FONT])
        (DEVICEWEIGHT [fetch WEIGHT of (COND
                                                  ((ffetch FONTDEVICESPEC of FONT)
                                                   (CADDR (ffetch FONTDEVICESPEC of FONT)))
                                                  (T (ffetch FONTFACE of FONT])
        (DEVICEEXPANSION 
             [fetch EXPANSION of (COND
                                            ((ffetch FONTDEVICESPEC of FONT)
                                             (CADDR (ffetch FONTDEVICESPEC of FONT)))
                                            (T (ffetch FONTFACE of FONT])
        (DEVICESIZE (COND
                       ((ffetch FONTDEVICESPEC of FONT)
                        (CADR (ffetch FONTDEVICESPEC of FONT)))
                       (T (ffetch FONTSIZE of FONT))))
        (DEVICEFAMILY (COND
                         ((ffetch FONTDEVICESPEC of FONT)
                          (CAR (ffetch FONTDEVICESPEC of FONT)))
                         (T (ffetch FONTFAMILY of FONT))))
        (SCALE (ffetch FONTSCALE of FONT))
        (\ILLEGAL.ARG PROP])

(\AVGCHARWIDTH
  [LAMBDA (FONT)                                         (* rmk%: "27-Nov-84 18:40")

    (* ;; "Returns the average width of a character, to be used in units-to-characters approximations, as in fixing the linelength")

    (PROG ((W (CHARWIDTH (CHARCODE A)
                     FONT)))
          (RETURN (COND
                     ((NEQ 0 W)
                      W)
                     ([NEQ 0 (SETQ W (FIXR (FTIMES 0.6 (FONTPROP FONT 'HEIGHT]
                      W)
                     (T 1])
)



(* ;; "Bitmap editing/manipulation:")

(DEFINEQ

(GETCHARBITMAP
  [LAMBDA (CHARCODE FONT)                                (* ; "Edited 26-Apr-89 21:49 by atm")
                                                             (* ; 
                    "returns a bitmap of the character CHARCODE from the font descriptor FONTDESC.")
    (COND
       ((OR (CHARCODEP CHARCODE)
            (EQ CHARCODE 256))                               (* ; 
                                       "bitmap for char 256 is what gets printed if char not found")
        )
       ((OR (STRINGP CHARCODE)
            (LITATOM CHARCODE))                              (* ; 
                                                 "For strings & litatoms, take the first character")
        (SETQ CHARCODE (CHCON1 CHARCODE)))
       ((TYPEP CHARCODE 'CL:CHARACTER)                       (* ; 
                                   "For common-lisp CHARACTERs, convert it to the char code first.")
        (SETQ CHARCODE (CL:CHAR-INT CHARCODE)))
       (T (\ILLEGAL.ARG CHARCODE)))
    (PROG (CBM (FONTDESC (\GETFONTDESC FONT))
               CSINFO CWDTH CHGHT)

     (* ;; "fetch the csinfo for the character set of this character.  Bitmaps and widths must be fetched from it")

          (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
                              FONTDESC))

     (* ;; "(\\fgetwidth (|fetch| (charsetinfo widths) |of| csinfo) (\\char8code charcode))")

          [SETQ CBM (BITMAPCREATE [SETQ CWDTH (if (fetch (CHARSETINFO IMAGEWIDTHS)
                                                         of CSINFO)
                                                  then (\FGETIMAGEWIDTH (fetch (CHARSETINFO
                                                                                        IMAGEWIDTHS)
                                                                               of CSINFO)
                                                                  (\CHAR8CODE CHARCODE))
                                                else (\FGETWIDTH (fetch (CHARSETINFO WIDTHS)
                                                                        of CSINFO)
                                                                (\CHAR8CODE CHARCODE]
                           (SETQ CHGHT (FONTPROP FONTDESC 'HEIGHT))
                           (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CHARSETINFO
                                                                                     CHARSETBITMAP)
                                                                            of CSINFO]
          (BITBLT (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
                 (\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO)
                        (\CHAR8CODE CHARCODE))
                 0 CBM 0 0 CWDTH CHGHT)
          (RETURN CBM])

(PUTCHARBITMAP
  [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT)   (* ; "Edited 27-Apr-89 11:19 by atm")

    (* ;; "stores the bitmap NEWCHARBITMAP as the character CHARCODE from the font descriptor FONTDESC.  If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.")

    (OR (TYPENAMEP NEWCHARBITMAP 'BITMAP)
        (\ILLEGAL.ARG NEWCHARBITMAP))
    (COND
       ((CHARCODEP CHARCODE))
       ((OR (STRINGP CHARCODE)
            (LITATOM CHARCODE))
        (SETQ CHARCODE (CHCON1 CHARCODE)))
       (T (\ILLEGAL.ARG CHARCODE)))
    (PROG* ((FONTDESC (\GETFONTDESC FONT))
            (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
                           FONTDESC))
            (CDESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
            (CASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
            (CHEIGHT (IPLUS CDESCENT CASCENT))
            (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
            (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
            (IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))
            (CIMWIDTH (if IMWIDTHS
                          then (\FGETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE))
                        else NIL))
            (CWIDTH (OR CIMWIDTH (CHARWIDTH CHARCODE FONTDESC)))
            (FONTBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
            (OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP))
            TEMPBITMAP BWIDTH DW BHEIGHT BASCENT BDESCENT NDESCENT NASCENT NHEIGHT CHAROFFSET
            (BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of FONTBITMAP)))

     (* ;; "fetch the ascents and descents of the bitmap and the new maximums.")

           (SETQ BWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP))
           (SETQ BHEIGHT (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP))
           (SETQ BDESCENT (OR NEWCHARDESCENT CDESCENT))
           (SETQ BASCENT (IDIFFERENCE BHEIGHT BDESCENT))
           (SETQ NDESCENT (IMAX BDESCENT CDESCENT))
           (SETQ NASCENT (IMAX BASCENT CASCENT))
           (SETQ NHEIGHT (IPLUS NDESCENT NASCENT))
           (SETQ CHAROFFSET (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE)))

     (* ;; "set up a new target bitmap if any of the parameters have changed.")

           (COND
              ((EQ CHAROFFSET (\FGETOFFSET OFFSETS \MAXTHINCHAR))

               (* ;; "changing the bitmap for a character which formerly pointed at the slug character.  Allocate a new bitmap character bitmap for this.")

               (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH BWIDTH)
                                       NHEIGHT BITSPERPIXEL))
               (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      OFWIDTH CHEIGHT)                       (* ; "copy the old characters over.")
               (SETQ CHAROFFSET OFWIDTH))
              ((NEQ CWIDTH BWIDTH)

               (* ;; "The bitmaps differ in width;  create a new bitmap with things at the right places, then update widths and offsets.")

               (SETQ DW (IDIFFERENCE BWIDTH CWIDTH))         (* ; "Difference in character widths")
               (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW)
                                       NHEIGHT BITSPERPIXEL))(* ; 
                              "this may also be a taller bitmap if NHEIGHT is larger than CHEIGHT.")
               (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      CHAROFFSET CHEIGHT)                    (* ; 
                                                  "Copy that portion to the left of the character.")
               (BITBLT FONTBITMAP (IPLUS CHAROFFSET CWIDTH)
                      0 TEMPBITMAP (IPLUS CHAROFFSET BWIDTH)
                      (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      (ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWIDTH)))
                      CHEIGHT)                               (* ; 
                                             "Copy that portion to the right of the new character.")
               )
              ((OR (IGREATERP BASCENT CASCENT)
                   (IGREATERP BDESCENT CDESCENT))

               (* ;; "The new character is TALLER than the existing bitmap.  Make a larger bitmap.")

               (SETQ TEMPBITMAP (BITMAPCREATE OFWIDTH NHEIGHT BITSPERPIXEL))
               (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      OFWIDTH CHEIGHT)

               (* ;; "Copy the existing bitmap into it, adjusting for a larger descent in the new character (if there is one)")

               ))

     (* ;; "copy the new bitmap in and update parameters.")

           (BITBLT NEWCHARBITMAP 0 0 (OR TEMPBITMAP FONTBITMAP)
                  CHAROFFSET
                  (IMAX 0 (IDIFFERENCE NDESCENT BDESCENT))
                  BWIDTH BHEIGHT)
           [COND
              (TEMPBITMAP (UNINTERRUPTABLY
                              
                              (* ;; "update the parameters for this character set.")

                              (\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE)
                                     BWIDTH)                 (* ; 
                                                           "The new character's correct width")
                                                             (* ; 
                                                        "Make sure that we update imagewidths also")
                              (if IMWIDTHS
                                  then (\FSETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE)
                                                  BWIDTH))
                              (\FSETOFFSET OFFSETS (\CHAR8CODE CHARCODE)
                                     CHAROFFSET)
                              [COND
                                 (DW (for I from 0 to \MAXCHAR
                                        do               (* ; 
 "Run thru the offsets of later characters, adjusting them for the changed width of this character")
                                              (if (IGREATERP (\FGETOFFSET OFFSETS I)
                                                             CHAROFFSET)
                                                  then (\FSETOFFSET OFFSETS I
                                                                  (IPLUS DW (\FGETOFFSET OFFSETS I]
                              (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with 
                                                                                           TEMPBITMAP
                                     )
                              (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with 
                                                                                            NDESCENT)
                              (replace (CHARSETINFO CHARSETASCENT) of CSINFO with NASCENT
                                     )

                              (* ;; "update the properties for the font as a whole.")

                              [SETQ NASCENT (IMAX NASCENT (FONTPROP FONTDESC 'ASCENT]
                              [SETQ NDESCENT (IMAX NDESCENT (FONTPROP FONTDESC 'DESCENT]
                              (replace (FONTDESCRIPTOR \SFAscent) of FONTDESC with 
                                                                                            NASCENT)
                              (replace (FONTDESCRIPTOR \SFDescent) of FONTDESC with
                                                                                       NDESCENT)
                              (replace (FONTDESCRIPTOR \SFHeight) of FONTDESC
                                 with (IPLUS NDESCENT NASCENT)))]
           (RETURN NEWCHARBITMAP])

(MOVECHARBITMAP
  [LAMBDA (SRCECODE SRCEFONT DESTCODE DESTFONT CLIP)     (* ; "Edited 14-Dec-86 18:04 by Shih")

(* ;;; "moves a character from one font to another, clipping if necessary.")

    (PROG ((SRCEDESC (\GETFONTDESC SRCEFONT))
           (DESTDESC (\GETFONTDESC DESTFONT))
           SRCEASCENT SRCEDESCENT DESTASCENT DESTDESCENT CHARBITMAP TEMPBITMAP NEWASCENT NEWDESCENT)
          (SETQ CHARBITMAP (GETCHARBITMAP SRCECODE SRCEFONT))
          (SETQ SRCEASCENT (FONTPROP SRCEDESC 'ASCENT))
          (SETQ DESTASCENT (FONTPROP DESTDESC 'ASCENT))
          (SETQ SRCEDESCENT (FONTPROP SRCEDESC 'DESCENT))
          (SETQ DESTDESCENT (FONTPROP DESTDESC 'DESCENT))
          [SETQ NEWASCENT (COND
                             (CLIP DESTASCENT)
                             (T (IMAX SRCEASCENT DESTASCENT]
          [SETQ NEWDESCENT (COND
                              (CLIP DESTDESCENT)
                              (T (IMAX SRCEDESCENT DESTDESCENT]
          [COND
             ((OR (NEQ SRCEASCENT NEWASCENT)
                  (NEQ SRCEDESCENT NEWDESCENT))
              (SETQ TEMPBITMAP (BITMAPCREATE (BITMAPWIDTH CHARBITMAP)
                                      (IPLUS NEWASCENT NEWDESCENT)))
              (BITBLT CHARBITMAP 0 (IMAX 0 (IDIFFERENCE SRCEDESCENT NEWDESCENT))
                     TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NEWDESCENT SRCEDESCENT))
                     (BITMAPWIDTH CHARBITMAP)
                     (IMIN (IPLUS SRCEASCENT SRCEDESCENT)
                           (IPLUS NEWASCENT NEWDESCENT]
          (PUTCHARBITMAP DESTCODE DESTFONT (OR TEMPBITMAP CHARBITMAP)
                 NEWDESCENT])
)
(DEFINEQ

(FONTCOPY
  [LAMBDA FONTSPECS                                      (* ; "Edited 10-Nov-87 17:12 by FS")
                                                             (* ; 
                                            "makes a copy of a font changing the specified fields.")
    (PROG (NOERROR ERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT)

     (* ;; "Set NOERROR if we find it as a prop, but set ERROR if we find a PROP which is illegal.  Then just return NIL if NOERROR and ERROR, otherwise, call FONTCREATE.")

          [SETQ OLDFONT (\GETFONTDESC (ARG FONTSPECS 1)
                               (AND (type? FONTCLASS (ARG FONTSPECS 1))
                                    (COND
                                       ((AND (EQ FONTSPECS 2)
                                             (LISTP (ARG FONTSPECS 2)))
                                        (LISTGET (ARG FONTSPECS 2)
                                               'DEVICE))
                                       (T (for I from 2 by 2 to FONTSPECS
                                             do (COND
                                                       ((AND (NEQ I FONTSPECS)
                                                             (EQ (ARG FONTSPECS I)
                                                                 'DEVICE))
                                                        (RETURN (ARG FONTSPECS (ADD1 I]
          (SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of OLDFONT))
          (SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of OLDFONT))
          (SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT))
          (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of OLDFONT))
          (SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of OLDFONT))
          [for I VAL from 2 by 2 to FONTSPECS
             do [SETQ VAL (COND
                                 ((NOT (EQ I FONTSPECS))
                                  (ARG FONTSPECS (ADD1 I]
                   (SELECTQ (ARG FONTSPECS I)
                       (FAMILY (SETQ FAMILY VAL))
                       (SIZE (SETQ SIZE VAL))
                       (FACE (SETQ FACE (\FONTFACE VAL)))
                       (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL)))
                       (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL)))
                       (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL)))
                       (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL)))
                       (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL)))
                       (ROTATION (SETQ ROTATION VAL))
                       (DEVICE (SETQ DEVICE VAL))
                       (NOERROR (SETQ NOERROR VAL))
                       (COND
                          [(AND (EQ I 2)
                                (EQ FONTSPECS 2)
                                (LISTP (ARG FONTSPECS 2)))
                           (for J on (ARG FONTSPECS 2) by (CDDR J)
                              do (SETQ VAL (CADR J))
                                    (SELECTQ (CAR J)
                                        (FAMILY (SETQ FAMILY VAL))
                                        (SIZE (SETQ SIZE VAL))
                                        (FACE (SETQ FACE (\FONTFACE VAL)))
                                        (WEIGHT (SETQ FACE (create FONTFACE
                                                              using FACE WEIGHT _ VAL)))
                                        (SLOPE (SETQ FACE (create FONTFACE
                                                             using FACE SLOPE _ VAL)))
                                        (EXPANSION (SETQ FACE (create FONTFACE
                                                                 using FACE EXPANSION _ VAL)))
                                        (BACKCOLOR (SETQ FACE (create FONTFACE
                                                                 using FACE BACKCOLOR _ VAL)))
                                        (FORECOLOR (SETQ FACE (create FONTFACE
                                                                 using FACE FORECOLOR _ VAL)))
                                        (ROTATION (SETQ ROTATION VAL))
                                        (DEVICE (SETQ DEVICE VAL))
                                        (NOERROR (SETQ NOERROR VAL))
                                        (COND
                                           (NOERROR 

                                                  (* ;; 
  "Fell through the SELECTQ, so an illegal PROP.  But, if NOERROR, just note the error, otherwise ")

                                                  (SETQ ERROR T))
                                           (T (\ILLEGAL.ARG (CAR J]
                          (T (if NOERROR
                                 then (SETQ ERROR T)
                               else (\ILLEGAL.ARG (ARG FONTSPECS I]
          (RETURN (if (AND NOERROR ERROR)
                      then NIL
                    else (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR])

(FONTSAVAILABLE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?)
                                                             (* rrb " 7-Nov-84 15:41")

(* ;;; "returns a list of the fonts fitting a description that are available.  FAMILY SIZE FACE or ROTATION can be * which means get them all.  if LOADEDONLYFLG is non-NIL, only fonts in core will be considered.")

    (DECLARE (GLOBALVARS IMAGESTREAMTYPES))
    (PROG (FONTX DEV)
          [SETQ DEV (COND
                       ((type? STREAM DEVICE)
                        (COND
                           ((LISTP (SETQ DEV (IMAGESTREAMTYPE DEVICE)))
                            (CAR DEV))
                           (T DEV)))
                       (DEVICE)
                       (T 'DISPLAY]
          (RETURN
           (COND
              ((LISTP FAMILY)
               (COND
                  ((EQ (CAR FAMILY)
                       'FONT)
                   (SETQ FONTX (CDR FAMILY)))
                  (T (SETQ FONTX FAMILY)))
               (FONTSAVAILABLE (CAR FONTX)
                      (OR (CADR FONTX)
                          SIZE)
                      (OR (CADDR FONTX)
                          FACE)
                      (OR (CADDDR FONTX)
                          ROTATION)
                      DEV CHECKFILESTOO?))
              ([SETQ FONTX (COND
                              ((type? FONTDESCRIPTOR FAMILY)
                               FAMILY)
                              ((NULL FAMILY)
                               (DEFAULTFONT DEV))
                              ((type? FONTCLASS FAMILY)

                               (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.  Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.")
                                                             (* ; 
                                                       "I don't know what to do in this case- rrb.")
                               (\COERCEFONTDESC FAMILY DEV T))
                              ((OR (IMAGESTREAMP FAMILY)
                                   (type? WINDOW FAMILY))
                               (DSPFONT NIL FAMILY]          (* ; 
                 "FAMILY was a spec for a font descriptor, use it and extend it by the other args.")
               (FONTSAVAILABLE (FONTPROP FONTX 'FAMILY)
                      (OR SIZE (FONTPROP FONTX 'SIZE))
                      (OR FACE (FONTPROP FONTX 'FACE))
                      (OR ROTATION (FONTPROP FONTX 'ROTATION))
                      (OR DEVICE (FONTPROP FONTX 'DEVICE))
                      CHECKFILESTOO?))
              (T (PROG ((FONTFACE FACE))
                   RETRY
                       (OR (LITATOM FAMILY)
                           (LISPERROR "ARG NOT LITATOM" FAMILY T))
                       (OR (AND (FIXP SIZE)
                                (IGREATERP SIZE 0))
                           (EQ SIZE '*)
                           (\ILLEGAL.ARG SIZE))
                       [OR (EQ FONTFACE '*)
                           (SETQ FONTFACE (OR (\FONTFACE FACE T)
                                              (RETURN NIL]
                       (OR (U-CASEP FAMILY)
                           (SETQ FAMILY (U-CASE FAMILY)))
                       (COND
                          ((NULL ROTATION)
                           (SETQ ROTATION 0))
                          ((AND (FIXP ROTATION)
                                (IGEQ ROTATION 0)))
                          ((EQ ROTATION '*))
                          (T (\ILLEGAL.ARG ROTATION)))
                       (RETURN (UNION (\LOOKUPFONTSINCORE FAMILY SIZE FONTFACE ROTATION DEV)
                                      (COND
                                         ((NOT CHECKFILESTOO?)
                                          NIL)
                                         [(EQ DEV '*)        (* ; "map thru all the devices.")
                                          (for EXTANTDEV in IMAGESTREAMTYPES
                                             join (APPLY* (OR (CADR (ASSOC 'FONTSAVAILABLE
                                                                               (CDR EXTANTDEV)))
                                                                  (FUNCTION NILL))
                                                             FAMILY SIZE FONTFACE ROTATION
                                                             (CAR EXTANTDEV]
                                         (T                  (* ; 
                                                           "apply the device font lookup function.")
                                            (APPLY* (OR [CADR (ASSOC 'FONTSAVAILABLE
                                                                     (CDR (ASSOC DEV IMAGESTREAMTYPES
                                                                                 ]
                                                        (FUNCTION NILL))
                                                   FAMILY SIZE FONTFACE ROTATION DEV])

(FONTFILEFORMAT
  [LAMBDA (STRM LEAVEOPEN)                               (* rmk%: "11-Sep-84 17:16")
                                                             (* ; "Returns the font format of STRM")
    [OR (OPENP STRM 'INPUT)
        (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD]
    (PROG1 (SELECTC (\WIN STRM)
               ((LIST (LLSH 1 15)
                      (LOGOR (LLSH 1 15)
                             (LLSH 1 13))) 

                                 (* ;; "If high bit of type is on, then must be strike.  If 2nd bit is on, must be strike-index, and we punt.  We don't care about the 3rd bit")

                    
                    (* ;; "first word has high bits (onebit index fixed).  Onebit means 'new-style font' , index is 0 for simple strike, 1 for index, and fixed is if all chars have max width.  Lisp doesn't care about 'fixed'")

                    'STRIKE)
               ((LOGOR (LLSH 16 8)
                       12) 
                           (* ;; "This is the length of a standard index header.  Other files could also have this value, but it's a pretty good discriminator")

                    
                    (* ;; "Skip to byte 25;  do it with BINS so works for non-randaccessp devices.  This skips the standard name header, then look for type 3 in the following header")

                    (FRPTQ 22 (\BIN STRM))                   (* ; "(SETFILEPTR STRM 25)")
                    (AND (EQ 3 (LRSH (\BIN STRM)
                                     4))
                         'AC))
               NIL)
        (OR LEAVEOPEN (CLOSEF STRM)))])

(FONTP
  [LAMBDA (X)                                            (* rmk%: "13-Sep-84 09:04")
                                                             (* ; "is X a FONTDESCRIPTOR?")
    (COND
       ((OR (type? FONTDESCRIPTOR X)
            (type? FONTCLASS X))
        X])

(FONTUNPARSE
  [LAMBDA (FONT)                                         (* kbr%: "25-Feb-86 19:40")

    (* ;; "Produces a minimal specification of the font or fontclass specification, for dumping by Tedit, imageobjects.")

    (PROG (FACE SPEC)
          (SETQ SPEC (COND
                        ((type? FONTDESCRIPTOR FONT)
                         (FONTPROP FONT 'SPEC))
                        [(type? FONTCLASS FONT)
                         (RETURN (CONS 'CLASS (FONTCLASSUNPARSE FONT]
                        (T 
                           (* ;; "Could be a non-instantiated specification in a fontclass, just use it as the spec without creating the font.")

                           FONT)))
          (OR SPEC (RETURN))
          (SETQ FACE (CADDR SPEC))                           (* ; 
                        "FACE and rotation can be NIL for a non-fontdescriptor fontclass component")
          [SETQ FACE (COND
                        ([OR (NULL FACE)
                             (EQUAL FACE '(MEDIUM REGULAR REGULAR]
                         NIL)
                        ((LITATOM FACE)
                         FACE)
                        [(LISTP FACE)
                         (PACK (LIST* (NTHCHAR (fetch (FONTFACE WEIGHT) of FACE)
                                             1)
                                      (NTHCHAR (fetch (FONTFACE SLOPE) of FACE)
                                             1)
                                      (NTHCHAR (fetch (FONTFACE EXPANSION) of FACE)
                                             1)
                                      (COND
                                         ((fetch (FONTFACE COLOR) of FACE)
                                          (LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE)
                                                "-"
                                                (fetch (FONTFACE FORECOLOR) of FACE]
                        (T (SHOULDNT]                        (* ; 
                                                    "Don't return device, or any trailing defaults")
          (RETURN (CONS (CAR SPEC)
                        (CONS (CADR SPEC)
                              (COND
                                 ([AND (CADDDR SPEC)
                                       (NOT (EQ 0 (CADDDR SPEC]
                                  (LIST (OR FACE 'MRR)
                                        (CADDDR SPEC)))
                                 (FACE (CONS FACE])

(SETFONTDESCRIPTOR
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT)        (* ; "Edited  1-Aug-88 16:16 by rmk:")
                                                             (* ; "Edited  5-Mar-87 19:28 by FS")

    (* ;; "saves a font descriptor under a family/size/face/rotation/device key so that it will be retreived by FONTCREATE.  This is a user entry.")

    (DECLARE (GLOBALVARS \FONTSINCORE))
    (SETQ DEVICE (\DEVICESYMBOL DEVICE))                 (* ; "Unpackageify")
    (AND FONT (SETQ FONT (\COERCEFONTDESC FONT DEVICE))) (* ; 
                            "NIL is used to clobber existing font so that next use will reread it.")
    (SETQ FAMILY (\FONTSYMBOL FAMILY))                   (* ; "Unpackageify")
    (SETQ FACE (\FONTFACE FACE NIL DEVICE))
    (OR ROTATION (SETQ ROTATION 0))
    (OR (AND (FIXP SIZE)
             (IGEQ SIZE 0))
        (\ILLEGAL.ARG SIZE))
    (PROG [(X (OR (FASSOC FAMILY \FONTSINCORE)
                  (CAR (push \FONTSINCORE (LIST FAMILY]
          [SETQ X (OR (FASSOC SIZE (CDR X))
                      (CAR (push (CDR X)
                                  (LIST SIZE]
          [SETQ X (OR (SASSOC FACE (CDR X))
                      (CAR (push (CDR X)
                                  (LIST FACE]                (* ; "SASSOC cause FACE is listp")
          [SETQ X (OR (FASSOC ROTATION (CDR X))
                      (CAR (push (CDR X)
                                  (LIST ROTATION]
          [SETQ X (OR (FASSOC DEVICE (CDR X))
                      (CAR (push (CDR X)
                                  (LIST DEVICE]
          (RPLACD X FONT)
          (RETURN FONT])

(CHARCODEP
  [LAMBDA (CHCODE)                                       (* gbn "22-Jul-85 16:35")
                                                             (* ; 
                                                           "is CHCODE a legal character code?")
    (AND (SMALLP CHCODE)
         (IGEQ CHCODE 0)
         (ILEQ CHCODE \MAXNSCHAR])

(EDITCHAR
  [LAMBDA (CHARCODE FONT)                                (* rrb "24-MAR-82 12:22")
                                                             (* ; 
                                                 "calls the bitmap editor on a character of a font")
    (PROG ((FONTDESC (\GETFONTDESC FONT)))
          (RETURN (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC])

(\STREAMCHARWIDTH
  [LAMBDA (CHARCODE STREAM TTBL)                         (* JonL " 8-NOV-83 03:31")

    (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for the various escape sequences.  Used by \ECHOCHAR")

    (SETQ CHARCODE (LOGAND CHARCODE \CHARMASK))
    ((LAMBDA (WIDTHSVECTOR)

       (* ;; "Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean that the character's glyph simply isn't loaded;  e.g., it may want #^A")

       (SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM)
                                   (SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM))
                                   (ffetch DDWIDTHSCACHE of WIDTHSVECTOR))
                              \UNITWIDTHSVECTOR))
       (SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA)
                                                      of (OR (TERMTABLEP TTBL)
                                                                 \PRIMTERMTABLE))
                                                CHARCODE))
           (INDICATE.CCE ([LAMBDA (CC)
                            (IPLUS (if (IGEQ CHARCODE (CHARCODE %#^@))
                                       then              (* ; 
                                          "A META charcode -- implies that the 8th bit is non-zero")
                                             (SETQ CC (LOADBYTE CHARCODE 0 7))
                                             (\FGETWIDTH WIDTHSVECTOR (CHARCODE %#))
                                     else 0)
                                   (if (ILESSP CC (CHARCODE SPACE))
                                       then              (* ; "A CONTROL charcode")
                                             (add CC (CONSTANT (LLSH 1 6)))
                                             (\FGETWIDTH WIDTHSVECTOR (CHARCODE ^))
                                     else 0)
                                   (\FGETWIDTH WIDTHSVECTOR CC]
                          CHARCODE))
           (SIMULATE.CCE (SELCHARQ CHARCODE
                              ((EOL CR LF BELL) 
                                   NIL)
                              (ESCAPE (\FGETWIDTH WIDTHSVECTOR (CHARCODE $)))
                              (TAB (PROG ((SPACEWIDTH (\FGETWIDTH WIDTHSVECTOR (CHARCODE SPACE)))
                                          (NEWXPOSITON (DSPXPOSITION NIL STREAM))
                                          TABWIDTH)
                                         (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
                                         [add NEWXPOSITON (SETQ TABWIDTH
                                                               (IDIFFERENCE
                                                                TABWIDTH
                                                                (IMOD (IDIFFERENCE NEWXPOSITON
                                                                             (DSPLEFTMARGIN NIL 
                                                                                    STREAM))
                                                                      TABWIDTH]
                                         (RETURN (if (IGREATERP NEWXPOSITON (DSPRIGHTMARGIN
                                                                                 NIL STREAM))
                                                     then 
                                                             (* ; 
                                                           "tab was past rightmargin, force cr.")
                                                           NIL
                                                   else TABWIDTH))))
                              (\FGETWIDTH WIDTHSVECTOR CHARCODE)))
           (REAL.CCE (SELECTC CHARCODE
                         ((CHARCODE (EOL CR LF)) 
                              NIL)
                         (ERASECHARCODE NIL)
                         (\FGETWIDTH WIDTHSVECTOR CHARCODE)))
           (IGNORE.CCE 0)
           (SHOULDNT])

(\UNITWIDTHSVECTOR
  [LAMBDA NIL                                            (* JonL " 7-NOV-83 19:23")
    (SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXCHAR 3)
                                                WORDSPERCELL)))
    (for I from 0 to (IPLUS \MAXCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1))
    \UNITWIDTHSVECTOR])

(\CREATEDISPLAYFONT
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)     (* gbn%: "25-Jan-86 18:02")
    (PROG [(FONTDESC (create FONTDESCRIPTOR
                            FONTDEVICE _ DEVICE
                            FONTFAMILY _ FAMILY
                            FONTSIZE _ SIZE
                            FONTFACE _ FACE
                            \SFAscent _ 0
                            \SFDescent _ 0
                            \SFHeight _ 0
                            ROTATION _ ROTATION
                            FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE]
          (RETURN (COND
                     ((\GETCHARSETINFO CHARSET FONTDESC T)
                      FONTDESC)
                     (T NIL])

(\CREATECHARSET.DISPLAY
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
                                                             (* ; "Edited 14-Jan-88 23:42 by FS")

    (* ;; "Color Stuff removed  -FS.")

    (* ;; "Replace Cond below with")

    (* ;; "(PROG (XCSINFO)")

    (* ;; "(SETQ XCSINFO &)")

    (* ;; "(COND ((FMEMB DEVICE \\COLORDISPLAYSTREAMTYPES) (SETQ XCSINFO (\\SFMAKECOLOR XCSINFO (OR (|fetch| (FONTFACE BACKCOLOR) |of| FACE) 0) (OR (|fetch| (FONTFACE FORECOLOR) |of| FACE) (MAXIMUMCOLOR (\\DISPLAYSTREAMTYPEBPP DEVICE))) (\\DISPLAYSTREAMTYPEBPP DEVICE)))))")

    (* ;; "(RETURN XCSINFO)))")

(* ;;; "tries to build the csinfo required for CHARSET.  Does the necessary coercions.")

(* ;;; 
"NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")

    (DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS))

    (* ;; "DISPLAYFONTCOERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...).  Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a similar list.")

    (COND
       ((PROG1 (for TRANSL in DISPLAYFONTCOERCIONS bind NEWCSINFO UFONT REALFONT
                  when (AND (SETQ UFONT (CAR TRANSL))
                                (EQ FAMILY (CAR UFONT))
                                (OR (NOT (CADR UFONT))
                                    (EQ SIZE (CADR UFONT)))
                                (OR (NOT (CADDR UFONT))
                                    (EQ CHARSET (CADDR UFONT)))
                                (SETQ REALFONT (CADR TRANSL))
                                (SETQ NEWCSINFO (\CREATECHARSET.DISPLAY (OR (CAR REALFONT)
                                                                                FAMILY)
                                                       (OR (CADR REALFONT)
                                                           SIZE)
                                                       FACE ROTATION DEVICE (OR (CADDR REALFONT)
                                                                                CHARSET)
                                                       FONTDESC NOSLUG?))) do (RETURN NEWCSINFO))
                                                             (* ; 
                        "Just recursively call ourselves to handle entries in DISPLAYFONTCOERCIONS")
               ))
       (T 
          (* ;; "One weirdness is, if you have a coercion, and the real-font is missing, you can't get a missingfont coercion on the user-font because the real-font missingfont coercion shadows it out.")

          (\CREATE-REAL-CHARSET.DISPLAY FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?
                 ])

(\CREATE-REAL-CHARSET.DISPLAY
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
                                                             (* ; "Edited 15-Jan-88 00:02 by FS")
    (COND
       [(AND (EQ ROTATION 0)
             (PROG1 (\READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION 'DISPLAY CHARSET)
                                                             (* ; 
 "If it is available, this will force the appropriate file to be read to fill in the charset entry")
                    ]
       (T 
          (* ;; "if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised 'by hand'.  Past that point, we do not allow DISPLAYFONTCOERCIONS, only MISSINGxxxxDISPLAYFONTCOERCIONS.")

          (PROG (NEWFONT XFONT XLATEDFAM CSINFO)
                (RETURN (COND
                           [(NEQ ROTATION 0)

                            (* ;; "to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.  If its still missing, then search for missing display font coercions (e.g. no avail. charset, *but*, do not recurse (avoid getting into infinite loops).  This allows partial permutations of fonts.")

                            (OR (MEMB ROTATION '(90 270))
                                (ERROR "only implemented rotations are 0, 90 and 270." ROTATION))
                            (COND
                               ((SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE FACE 0 'DISPLAY 
                                                   CHARSET))

                                (* ;; "Do not call FONTCREATE here.  The user might have modified (via PUTCHARBITMAP, etc.) the in-memory version of the source.  This also fixes a bug in which several font descriptors ended up sharing bitmaps or charsetvectors, causing havoc when the user modifies either fontdescriptor.")

                                (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
                                    then (\SFROTATECSINFO CSINFO ROTATION)
                                  else NIL]
                           ((AND (EQ (fetch WEIGHT of FACE)
                                     'BOLD)
                                 (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE
                                                    (create FONTFACE using FACE WEIGHT _
                                                                               'MEDIUM)
                                                    0
                                                    'DISPLAY CHARSET)))

                            (* ;; "if we want a bold font, and the medium weight font is available, build the medium weight version then call \SFMAKEBOLD on the csinfo")

                            (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
                                then (\SFMAKEBOLD CSINFO)
                              else NIL))
                           ((AND (EQ (fetch (FONTFACE SLOPE) of FACE)
                                     'ITALIC)
                                 (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE
                                                    (create FONTFACE using FACE SLOPE _
                                                                               'REGULAR)
                                                    0
                                                    'DISPLAY CHARSET)))
                            (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
                                then (\SFMAKEITALIC CSINFO)
                              else NIL))
                           [(AND CHARSET (NOT (EQL 0))
                                 (for TRANSL in MISSINGCHARSETDISPLAYFONTCOERCIONS
                                    bind NEWCSINFO UFONT REALFONT
                                    when (AND (SETQ UFONT (CAR TRANSL))
                                                  (EQ FAMILY (CAR UFONT))
                                                  (OR (NOT (CADR UFONT))
                                                      (EQ SIZE (CADR UFONT)))
                                                  (OR (NOT (CADDR UFONT))
                                                      (EQ CHARSET (CADDR UFONT)))
                                                  (SETQ REALFONT (CADR TRANSL))
                                                  (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY
                                                                   (OR (CAR REALFONT)
                                                                       FAMILY)
                                                                   (OR (CADR REALFONT)
                                                                       SIZE)
                                                                   FACE ROTATION DEVICE
                                                                   (OR (CADDR REALFONT)
                                                                       CHARSET)
                                                                   FONTDESC NOSLUG?)))
                                    do (RETURN NEWCSINFO]
                           ((for TRANSL in MISSINGDISPLAYFONTCOERCIONS bind NEWCSINFO 
                                                                                     UFONT REALFONT
                               when (AND (SETQ UFONT (CAR TRANSL))
                                             (EQ FAMILY (CAR UFONT))
                                             (OR (NOT (CADR UFONT))
                                                 (EQ SIZE (CADR UFONT)))
                                             (OR (NOT (CADDR UFONT))
                                                 (EQ CHARSET (CADDR UFONT)))
                                             (SETQ REALFONT (CADR TRANSL))
                                             (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY
                                                              (OR (CAR REALFONT)
                                                                  FAMILY)
                                                              (OR (CADR REALFONT)
                                                                  SIZE)
                                                              FACE ROTATION DEVICE
                                                              (OR (CADDR REALFONT)
                                                                  CHARSET)
                                                              FONTDESC NOSLUG?)))
                               do (RETURN NEWCSINFO)))
                           ((NOT NOSLUG?)
                            (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
                                                     of FONTDESC)
                                   (FONTPROP FONTDESC 'ASCENT)
                                   (FONTPROP FONTDESC 'DESCENT)
                                   (FONTPROP FONTDESC 'DEVICE])

(\BUILDSLUGCSINFO
  [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE)            (* ; "Edited  9-May-93 23:12 by rmk:")

(* ;;; "builds a csinfo which contains only the slug (black rectangle) character.  Called only for display.")

    (SETQ SCALE (OR SCALE 1))
    (PROG ((CSINFO (create CHARSETINFO
                          CHARSETASCENT _ ASCENT
                          CHARSETDESCENT _ DESCENT))
           WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
          (REPLACE IMAGEWIDTHS OF CSINFO WITH WIDTHS)
          (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (
                                                                                 \CREATECSINFOELEMENT
                                                                                   )))
          (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
          [replace (CHARSETINFO CHARSETBITMAP) of CSINFO
             with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE))
                                          (ROUND (QUOTIENT (IPLUS ASCENT DESCENT)
                                                        SCALE]
          [BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE]
          (RETURN CSINFO])

(\SEARCHDISPLAYFONTFILES
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)             (* ; "Edited  5-Mar-87 18:55 by FS")

    (* ;; "     This function called via APPLY in IMAGESTREAMTYPES.")

    (* ;; "     Returns a list of the fonts that can be read in for displaylike devices.  Rotation is ignored because it is assumed that all devices support 0 90 and 270.")

    (* ;; "     Note we *allow* a device that is not 'DISPLAY for guys like 4DISPLAY, 8DISPLAY, 24DISPLAY, and also possibly for FX80,  etc. (guys that want DISPLAYFONTS anyway).  Should have some hook though for FONTEXTENSIONS, FONTDIRECTORIES??")

    (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
    (SELECTQ (SYSTEMTYPE)
        (D (\SEARCHFONTFILES FAMILY SIZE FACE ROTATION DEVICE DISPLAYFONTDIRECTORIES 
                  DISPLAYFONTEXTENSIONS))
        (J                                                   (* OLD J code from \READDISPLAYFONT
                                                           (PROG ((FONTFILE (\FONTFILENAME 
                                                           FAMILY SIZE FACE)) FONTDESC STRM)
                                                           (COND ((SETQ STRM (AND 
                                                           FONTDIRECTORIES (FINDFILE FONTFILE T 
                                                           FONTDIRECTORIES)))
                                                           (SETQ STRM (OPENSTREAM FONTFILE
                                                           (QUOTE INPUT))) (SETQ FONTDESC
                                                           (\READJERICHOFONTFILE FAMILY SIZE 
                                                           FACE STRM)) (CLOSEF STRM)))
                                                           (RETURN FONTDESC)))
           NIL)
        (SHOULDNT])

(\SEARCHFONTFILES
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST)   (* ; "Edited 14-Sep-96 10:54 by rmk:")
                                                             (* ; "Edited  6-Oct-89 12:34 by bvm")

    (* ;; "GENERIC FUNCTION")

    (* ;; "returns a list of the fonts that can be read in for a device.  Rotation is ignored because it is assumed that all devices support 0 90 and 270.")

    (SETQ FAMILY (\FONTSYMBOL FAMILY))
    (SETQ DEVICE (\FONTSYMBOL DEVICE))
    (SETQ FACE (\FONTFACE FACE))
    (BIND (FILING.ENUEMRATION.DEPTH _ 1)
           FONTSFOUND THISFONT THISFACE FOR E INSIDE EXTLST
       DO [FOR DIR INSIDE DIRLST
                 BIND (FILEPATTERN _ (IF (FMEMB E *OLD-FONT-EXTENSIONS*)
                                             THEN (\FONTFILENAME.OLD FAMILY SIZE FACE E)
                                           ELSE (\FONTFILENAME FAMILY SIZE FACE E)))
                 DO 

                       (* ;; "Hack above to handle both old and new font file names.  The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup.  If set to a list of extensions, just those will be looked up with old-style  conventions")

                       (FOR FONTFILE IN (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR
                                                                  'BODY FILEPATTERN))
                          WHEN [PROGN (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE DEVICE))
                                          (SETQ THISFACE (CADDR THISFONT))

                                          (* ;; 
                                        "make sure the face, size, and family really match.")

                                          (AND (NOT (MEMBER THISFONT FONTSFOUND))
                                               (OR (EQ FAMILY '*)
                                                   (EQ FAMILY (CAR THISFONT)))
                                               (OR (EQ SIZE '*)
                                                   (EQ SIZE (CADR THISFONT)))
                                               (OR (EQ FACE '*)
                                                   (EQUAL FACE THISFACE)
                                                   (AND (OR (EQ (CAR FACE)
                                                                '*)
                                                            (EQ (CAR FACE)
                                                                (CAR THISFACE)))
                                                        (OR (EQ (CADR FACE)
                                                                '*)
                                                            (EQ (CADR FACE)
                                                                (CADR THISFACE)))
                                                        (OR (EQ (CADDR FACE)
                                                                '*)
                                                            (EQ (CADDR FACE)
                                                                (CADDR THISFACE]
                          DO (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
       FINALLY (RETURN FONTSFOUND])

(\FINDFONTFILE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST)
                                                             (* ; "Edited 14-Sep-96 10:53 by rmk:")
                                                             (* ; "Edited  6-Oct-89 11:18 by bvm")

    (* ;; "Find any font file on any directory with any naming convention with any extension.  Note that ROTATION and DEVICE are just place holders.   DEVICE is irrelevant because DIRLST already incorporates the device information.  The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup.  If set to a list of extensions, just those will be looked up with old-style conventions.")

    (BIND FONTFILE FOR EXT INSIDE EXTLST
       WHEN (SETQ FONTFILE (FINDFILE (IF (FMEMB EXT *OLD-FONT-EXTENSIONS*)
                                             THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT 
                                                             CHARSET)
                                           ELSE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET))
                                      T DIRLST)) DO (RETURN FONTFILE])

(\FONTSYMBOL
  [LAMBDA (X ElseReturnXFlg)                             (* ; "Edited 28-Jul-88 11:59 by rmk:")
                                                             (* ; "Edited 24-Mar-87 14:32 by FS")

    (* ;; "Return a symbol in IL package and is in uppercase.  Currently the function IL:U-CASE is believed to do this, but if it changes, this is the font hook.  ElseReturnXFlg is if you want an IL symbol if X is a symbol or string, otherwise just X.")

    (COND
       ((LITATOM X)
        (U-CASE X))
       ((STRINGP X)
        (MKATOM (U-CASE X)))
       (ElseReturnXFlg X)
       (T (ERROR "Want an IL symbol"])

(\DEVICESYMBOL
  [LAMBDA (X ElseReturnXFlg)                             (* ; "Edited  7-Oct-88 20:07 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:43 by rmk:")
                                                             (* ; "Edited 24-Mar-87 14:33 by FS")

    (* ;; "Return a canonicalized atom good for comparing with DEVICE symbols")

    (LET ((STRM (\GETSTREAM X 'OUTPUT T)))
         (COND
            (STRM (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of
                                                                                         STRM)))
            ((NULL X)
             'DISPLAY)
            (T                                               (* ; "because its used in ASSOC.")
               (\FONTSYMBOL X ElseReturnXFlg])

(\FONTFACE
  [LAMBDA (FACE NOERRORFLG DEV)                          (* ; "Edited  1-Aug-88 09:44 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:50 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:49 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:41 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:38 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")
                                                             (* ; "Edited 25-Feb-87 22:58 by FS")

    (* ;; "Coerces FACE into standard FONTFACE record, usually returns a CONSTANT (so you'd better not RPLACD or REPLACE fields!!)")

    (PROG (UNKNOWN (WEIGHT 'MEDIUM)
                 (SLOPE 'REGULAR)
                 (EXPANSION 'REGULAR)
                 (OLDFACE FACE))

     (* ;; "On error, can signal, or return NIL, or return REGULAR face.")

          [SETQ UNKNOWN (COND
                           ((EQ NOERRORFLG 'REGULAR)
                            'REGULAR)
                           (T 'ERROR]
          [COND
             ((type? FONTFACE FACE)

              (* ;; "List Case.  Unpack because want to validate fields")

              (SETQ WEIGHT (fetch (FONTFACE WEIGHT) of FACE))
              (SETQ SLOPE (fetch (FONTFACE SLOPE) of FACE))
              (SETQ EXPANSION (fetch (FONTFACE EXPANSION) of FACE))

              (* ;; "Handle unknown faces")

              [OR (\FONT.SYMBOLMEMB WEIGHT '             (* BOLD MEDIUM LIGHT))
                  (SETQ WEIGHT (COND
                                  ((\FONT.COMPARESYMBOL WEIGHT 'REGULAR)

                                   (* ;; "Clean up WEIGHT REGULAR vs. MEDIUM")

                                   (SETQ WEIGHT 'MEDIUM))
                                  (T UNKNOWN]
              (OR (\FONT.SYMBOLMEMB SLOPE '              (* REGULAR ITALIC))
                  (SETQ SLOPE UNKNOWN))
              (OR (\FONT.SYMBOLMEMB EXPANSION '          (* COMPRESSED REGULAR EXPANDED))
                  (SETQ EXPANSION UNKNOWN)))
             ((OR (LITATOM FACE)
                  (STRINGP FACE))
              (COND
                 ((NULL FACE)                                (* ; "Fast vanilla default")
                  )
                 ((EQ (NCHARS FACE)
                      3)                                     (* ; "3 char notation case")
                  (SETQ WEIGHT (SELCHARQ (CHCON1 FACE)
                                    ((B b) 
                                         'BOLD)
                                    ((M m R r) 
                                         'MEDIUM)
                                    ((L l) 
                                         'LIGHT)
                                    UNKNOWN))
                  (SETQ SLOPE (SELCHARQ (NTHCHARCODE FACE 2)
                                   ((R r) 
                                        'REGULAR)
                                   ((I i) 
                                        'ITALIC)
                                   UNKNOWN))
                  (SETQ EXPANSION (SELCHARQ (NTHCHARCODE FACE 3)
                                       ((R r) 
                                            'REGULAR)
                                       ((C c) 
                                            'COMPRESSED)
                                       ((E e) 
                                            'EXPANDED)
                                       UNKNOWN)))
                 ((SELECTQ FACE
                      (BOLD (SETQ WEIGHT 'BOLD))
                      (ITALIC (SETQ SLOPE 'ITALIC))
                      (BOLDITALIC (SETQ WEIGHT 'BOLD)
                                  (SETQ SLOPE 'ITALIC))
                      ((STANDARD REGULAR) 
                           T)
                      NIL))
                 ((\FONT.COMPARESYMBOL FACE 'BOLD)
                  (SETQ WEIGHT 'BOLD))
                 ((\FONT.COMPARESYMBOL FACE 'ITALIC)
                  (SETQ SLOPE 'ITALIC))
                 ((\FONT.COMPARESYMBOL FACE 'BOLDITALIC)
                  (SETQ WEIGHT 'BOLD)
                  (SETQ SLOPE 'ITALIC))
                 ((\FONT.SYMBOLMEMB FACE '(STANDARD REGULAR NIL NNN))
                                                             (* ; "Vanilla case")
                  )
                 ((STRPOS "-" FACE)                          (* ; "Color fontface spec!")
                  (SETQ FACE (\FONTFACE.COLOR FACE NOERRORFLG DEV))
                  (RETURN FACE))
                 ((\FONT.SYMBOLMEMB FACE '               (* ***))
                                                             (* ; "Wildcard case")
                  (SETQ WEIGHT '*)
                  (SETQ SLOPE '*)
                  (SETQ EXPANSION '*))
                 (T                                          (* ; "Other litatom error case")
                    (SETQ WEIGHT UNKNOWN)
                    (SETQ SLOPE UNKNOWN)
                    (SETQ EXPANSION UNKNOWN]
          (if (OR (EQ WEIGHT 'ERROR)
                      (EQ SLOPE 'ERROR)
                      (EQ EXPANSION 'ERROR))
              then (if NOERRORFLG
                           then (RETURN NIL)
                         else (\ILLEGAL.ARG OLDFACE)))

     (* ;; "Avoid consing by returning constant faces (historical:  really, would have been better to return MRR, but users have know about this for too long (rmk))")

          (RETURN (COND
                     ((AND (EQ WEIGHT 'MEDIUM)
                           (EQ SLOPE 'REGULAR)
                           (EQ EXPANSION 'REGULAR))          (* ; "MRR")
                      (CONSTANT (create FONTFACE)))
                     [(AND (EQ WEIGHT 'BOLD)
                           (EQ SLOPE 'REGULAR)
                           (EQ EXPANSION 'REGULAR))          (* ; "BRR")
                      (CONSTANT (create FONTFACE
                                       WEIGHT _ 'BOLD]
                     [(AND (EQ WEIGHT 'MEDIUM)
                           (EQ SLOPE 'ITALIC)
                           (EQ EXPANSION 'REGULAR))          (* ; "MIR")
                      (CONSTANT (create FONTFACE
                                       SLOPE _ 'ITALIC]
                     [(AND (EQ WEIGHT 'BOLD)
                           (EQ SLOPE 'ITALIC)
                           (EQ EXPANSION 'REGULAR))          (* ; "BIR")
                      (CONSTANT (create FONTFACE
                                       WEIGHT _ 'BOLD
                                       SLOPE _ 'ITALIC]
                     (T                                      (* ; "Otherwise, cons up")
                        (create FONTFACE
                               WEIGHT _ WEIGHT
                               SLOPE _ SLOPE
                               EXPANSION _ EXPANSION])

(\FONTFACE.COLOR
  [LAMBDA (FACE NOERRORFLG DEV)                          (* ; "Edited 28-Jul-88 14:51 by rmk:")
                                                             (* ; "Edited 28-Jul-88 13:09 by rmk:")
                                                             (* ; "Edited 24-Mar-87 17:03 by FS")

    (* ;; "This used to be \FONTFACE.  Renamed \FONTFACE.COLOR, and \FONTFACE rewritten.  The section below should also be redone")

    (* ;; "Takes a variety of user specifications and converts them to a standard FONTFACE record.")

    (* ;; "b/w fontfaces are extended by an optional '-backcolor-forecolor'")

    (* ;; "the atom NNN is interpreted the same as NIL or MRR to cover up a bug described in AR 3025, the FONTNNN bug")

    (DECLARE (GLOBALVARS \COLORDISPLAYSTREAMTYPES))
    (SETQ DEV (\DEVICESYMBOL DEV))
    (PROG (BWFACE POS OLDPOS BITSPERPIXEL BACKCOLOR FORECOLOR ANSWER)

     (* ;; "First get a FONTFACE ANSWER.")

          [SETQ ANSWER (COND
                          ((type? FONTFACE FACE)
                           FACE)
                          ((LITATOM FACE)
                           (OR (U-CASEP FACE)
                               (SETQ FACE (U-CASE FACE)))
                           (SETQ POS (STRPOS "-" FACE))
                           (COND
                              [POS (SETQ BWFACE (SUBATOM FACE 1 (SUB1 POS]
                              (T (SETQ BWFACE FACE)))
                           [SETQ ANSWER (SELECTQ BWFACE
                                            ((* ***) 
                                                 (CONSTANT (create FONTFACE
                                                                  WEIGHT _ '*
                                                                  SLOPE _ '*
                                                                  EXPANSION _ '*)))
                                            ((NIL MRR STANDARD NNN) 
                                                 (CONSTANT (create FONTFACE)))
                                            ((ITALIC MIR) 
                                                 (CONSTANT (create FONTFACE
                                                                  SLOPE _ 'ITALIC)))
                                            ((BOLD BRR) 
                                                 (CONSTANT (create FONTFACE
                                                                  WEIGHT _ 'BOLD)))
                                            ((BOLDITALIC BIR) 
                                                 (CONSTANT (create FONTFACE
                                                                  WEIGHT _ 'BOLD
                                                                  SLOPE _ 'ITALIC)))
                                            (create FONTFACE
                                                   WEIGHT _ (SELCHARQ (NTHCHARCODE FACE 1)
                                                                 (M 'MEDIUM)
                                                                 (B 'BOLD)
                                                                 (L 'LIGHT)
                                                                 (GO ERROR))
                                                   SLOPE _ (SELCHARQ (NTHCHARCODE FACE 2)
                                                                (R 'REGULAR)
                                                                (I 'ITALIC)
                                                                (GO ERROR))
                                                   EXPANSION _ (SELCHARQ (NTHCHARCODE FACE 3)
                                                                    (R 'REGULAR)
                                                                    (C 'COMPRESSED)
                                                                    (E 'EXPANDED)
                                                                    (GO ERROR]
                           (COND
                              (POS                           (* ; "Color FONTFACE.  *")
                                   (SETQ OLDPOS POS)
                                   (SETQ POS (STRPOS "-" FACE (ADD1 OLDPOS)))
                                   (COND
                                      ((NULL POS)
                                       (GO ERROR)))
                                   (SETQ BITSPERPIXEL (\DISPLAYSTREAMTYPEBPP DEV))
                                   (SETQ BACKCOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
                                                                        (SUB1 POS))
                                                          BITSPERPIXEL))
                                   (SETQ OLDPOS POS)
                                   (SETQ FORECOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
                                                                        -1)
                                                          BITSPERPIXEL))
                                                             (* ; 
                                                         "COPY ANSWER to avoid smashing constants.")
                                   (SETQ ANSWER (COPY ANSWER))
                                   (replace (FONTFACE BACKCOLOR) of ANSWER with BACKCOLOR
                                          )
                                   (replace (FONTFACE FORECOLOR) of ANSWER with FORECOLOR
                                          )))
                           ANSWER)
                          (T (GO ERROR]

     (* ;; "Coerce on or off COLOR.")

          (SETQ ANSWER (COND
                          ((AND (NOT (FMEMB DEV \COLORDISPLAYSTREAMTYPES))
                                (fetch (FONTFACE COLOR) of ANSWER))
                           (SETQ ANSWER (COPY ANSWER))
                           (replace (FONTFACE COLOR) of ANSWER with NIL)
                           ANSWER)
                          ((AND (FMEMB DEV \COLORDISPLAYSTREAMTYPES)
                                (NULL (fetch (FONTFACE COLOR) of ANSWER)))
                           (SETQ FACE (COPY FACE))
                           (replace (FONTFACE BACKCOLOR) of ANSWER with 0)
                           (replace (FONTFACE FORECOLOR) of ANSWER with
                                                                           (MAXIMUMCOLOR (
                                                                                \DISPLAYSTREAMTYPEBPP
                                                                                          DEV)))
                           ANSWER)
                          (T ANSWER)))
          (RETURN ANSWER)
      ERROR
          (COND
             (NOERRORFLG (RETURN NIL))
             (T (\ILLEGAL.ARG FACE])

(\FONTFILENAME
  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)               (* ; "Edited  5-Mar-93 16:10 by rmk:")

    (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.  New name is of the form %"familysize-face-Ccharset.ext%", e.g., MODERN12-MRR-C357.WD")

    (* ;; "**bvm 10/5/89 Slight change: partition fonts into subdirectories by charset, e.g., all Charset zero fonts are in subdirectory C0>.  This significantly speeds up any font operation that requires any local directory work (e.g., NFS servers on both Sun and D machine), and FONTSAVAILABLE on any device (since it doesn't have to wade thru all those charsets).  This behavior is conditioned on the value of *USEOLDFONTDIRECTORIES*")

    (SETQ FACE (\FONTFACE FACE))                         (* ; "Validate face")
    (LET* ([SIZEPATT (COND
                        ((EQ SIZE '*)
                         SIZE)
                        ((FIXP SIZE)
                         (if (< SIZE 10)
                             then (CONCAT 0 SIZE)
                           else SIZE))
                        (T (\ILLEGAL.ARG SIZE]
           (CSETNAME (COND
                        ((OR (NULL CHARSET)
                             (EQ CHARSET 0))                 (* ; "Charset defaults to zero.")
                         "0")
                        ((FIXP CHARSET)
                         (LET ((*PRINT-BASE* 8)
                               (*PRINT-RADIX* NIL))          (* ; "Longhand for (cl:write-to-string charset :radix nil :base 8), which is twice as slow, due to lousy keyword handling")
                              (\PRINDATUM.TO.STRING CHARSET)))
                        (T                                   (* ; 
                                                           "Somebody made the string already?")
                           CHARSET)))
           [FACESPEC (LIST (CHCON1 (fetch (FONTFACE WEIGHT) of FACE))
                           (CHCON1 (fetch (FONTFACE SLOPE) of FACE))
                           (CHCON1 (fetch (FONTFACE EXPANSION) of FACE]
           (TAIL FACESPEC))
          [if (OR (EQ (CAR TAIL)
                          (CHARCODE *))
                      (EQ (CAR (SETQ TAIL (CDR TAIL)))
                          (CHARCODE *)))
              then                                       (* ; 
            "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower.")
                    (while (EQ (CADR TAIL)
                                   (CHARCODE *)) do (RPLACD TAIL (CDDR TAIL]

          (* ;; "Fortunately, CONCAT ignores packages.")

          (PACKFILENAME.STRING 'NAME (CONCAT (CL:IF *USEOLDFONTDIRECTORIES*
                                                 ""
                                                 (CONCAT (PROGN 
                                                             (* ; 
                   "Lowercase because it's in a directory name, so maybe Unix will find it sooner?")
                                                                "c")
                                                        CSETNAME ">"))
                                            FAMILY SIZEPATT "-" (CONCATCODES FACESPEC)
                                            "-C" CSETNAME)
                 'EXTENSION EXTENSION])

(\FONTFILENAME.OLD
  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)           (* ; "Edited 23-Sep-92 18:22 by jds")

    (* ;; "Returns old style font file names.  They were ambiguous because you could not ask for e.g. FACE (MEDIUM * REGULAR) because it maps to FamilySize-*-Charset, which also matches (BOLD * COMPRESSED), etc.  Keep this function around though for user's who don't rename their files.")
                                                             (* ; 
                     "Returns the name of the file that should contain the information for a font.")
    (SETQ FACE (\FONTFACE FACE))                         (* ; "Force legal canonical face")
    (SETQ FACE (COND
                  ((AND (EQ (CAR FACE)
                            '*)
                        (EQ (CADR FACE)
                            '*))

                   (* ;; "Avoid  adjacent wildcards because DSK gets slower exponentially (can take loooong tiiiiiime).  No need to check compression.")

                   '*)
                  (T FACE)))
    (PACKFILENAME.STRING 'NAME [PROGN 
                                      (* ;; "DISPLAYFONT AC WD and the default case")

                                      (CONCAT (CDR (SASSOC FAMILY *DISPLAY-FONT-NAME-MAP*))
                                             (COND
                                                ((EQ SIZE '*)
                                                 SIZE)
                                                ((FIXP SIZE)
                                                 (COND
                                                    ((< SIZE 10)
                                                     (CONCAT 0 SIZE))
                                                    (T SIZE)))
                                                (T (\ILLEGAL.ARG SIZE)))
                                             [COND
                                                ((EQ FACE '*)
                                                 '*)
                                                (T (SELECTQ (fetch WEIGHT of FACE)
                                                       (BOLD (SELECTQ (fetch SLOPE of FACE)
                                                                 (ITALIC "D")
                                                                 "B"))
                                                       (SELECTQ (fetch SLOPE of FACE)
                                                           (ITALIC "I")
                                                           "R"]
                                             (COND
                                                ((FIXP CHARSET)
                                                 (LET ((*PRINT-BASE* 8))
                                                      (CL:FORMAT NIL "~O" CHARSET)))
                                                (T "000"]
           'EXTENSION EXTENSION])

(\FONTFILENAME.NEW
  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)           (* ; "Edited 30-Mar-87 20:00 by FS")

    (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.")

    (LET (NAME SIZEPATT)
         (SETQ FACE (\FONTFACE FACE))                    (* ; "Validate face")
         [SETQ SIZEPATT (COND
                           ((EQ SIZE '*)
                            SIZE)
                           ((FIXP SIZE)
                            (if (< SIZE 10)
                                then (CONCAT 0 SIZE)
                              else SIZE))
                           (T (\ILLEGAL.ARG SIZE]

         (* ;; "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower.  Nicely, PACK & CONCAT ignore packages.")

         (PACKFILENAME.STRING 'NAME (CONCAT FAMILY SIZEPATT "-"
                                           [COND
                                              ((EQUAL FACE '

         (* * *)
)
                                               '*)
                                              (T (CONCAT (NTHCHAR (fetch (FONTFACE WEIGHT)
                                                                     of FACE)
                                                                1)
                                                        (NTHCHAR (fetch (FONTFACE SLOPE)
                                                                    of FACE)
                                                               1)
                                                        (NTHCHAR (fetch (FONTFACE EXPANSION)
                                                                    of FACE)
                                                               1]
                                           (COND
                                              [(FIXP CHARSET)
                                               (LET ((*PRINT-BASE* 8))
                                                    (CONCAT "-C" (\PRINDATUM.TO.STRING CHARSET]
                                              (CHARSET (CONCAT "-C" CHARSET))
                                              (T "-C0")))
                'EXTENSION EXTENSION])

(\FONTINFOFROMFILENAME
  [LAMBDA (FONTFILE DEVICE)                                  (* ; "Edited 14-Sep-96 10:23 by rmk:")
                                                             (* ; "Edited  5-Oct-89 18:28 by bvm")

    (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.  Rotation is 0 always.  Parses both new & old format files.")

    (LET ((FILENAMELIST (UNPACKFILENAME.STRING FONTFILE))
          CH SIZEBEG SIZEND NAME FAMILY SIZE FACE EXT)
         (SETQ NAME (LISTGET FILENAMELIST 'NAME))            (* ; 
         "find where the name and size are.  MUST check for ch nil below or possible infinite loop")
         (SETQ SIZEBEG (for CH# from 1 when (OR (NUMBERP (SETQ CH (NTHCHAR NAME CH#)))
                                                            (NULL CH)) do (RETURN CH#)))

         (* ;; "Get Family")

         [SETQ FAMILY (MKATOM (U-CASE (SUBSTRING NAME 1 (SUB1 SIZEBEG]

         (* ;; "Get Size")

         [SETQ SIZEND (find CH# from SIZEBEG suchthat (NOT (NUMBERP (NTHCHAR NAME CH#]
         [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
         (if (EQ (NTHCHAR NAME SIZEND)
                     '-)
             then (SETQ SIZEND (ADD1 SIZEND)))

         (* ;; "Get Face")

         (SETQ NAME (U-CASE NAME))                           (* ; 
                                                   "don't need name, but checks for lowercase face")
         [SETQ FACE (LIST (COND
                             ((STRPOS "B" NAME SIZEND NIL T NIL UPPERCASEARRAY)
                              'BOLD)
                             ((STRPOS "L" NAME SIZEND NIL T NIL UPPERCASEARRAY)
                              'LIGHT)
                             (T 'MEDIUM))
                          (COND
                             ((STRPOS "I" NAME SIZEND NIL NIL NIL UPPERCASEARRAY)
                              'ITALIC)
                             (T 'REGULAR))
                          (COND
                             ((STRPOS "E" NAME SIZEND NIL NIL NIL UPPERCASEARRAY)
                              'EXPANDED)
                             ((STRPOS "C-" NAME SIZEND NIL NIL NIL UPPERCASEARRAY)
                              'COMPRESSED)
                             (T 'REGULAR]
         (LIST FAMILY SIZE FACE 0 (COND
                                     ((STREAMP DEVICE)
                                      (IMAGESTREAMTYPE DEVICE))
                                     ((NULL DEVICE)
                                      [SETQ EXT (MKATOM (U-CASE (LISTGET FILENAMELIST 'EXTENSION]
                                      (SELECTQ EXT
                                          (WD 'INTERPRESS)
                                          ((STRIKE AC DISPLAYFONT) 
                                               'DISPLAY)
                                          EXT))
                                     ((LITATOM DEVICE)
                                      (\FONTSYMBOL DEVICE))
                                     (T DEVICE])

(\FONTINFOFROMFILENAME.OLD
  [LAMBDA (FONTFILE DEVICE)                              (* ; "Edited  1-Jan-87 01:29 by FS")

    (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.")

    (PROG ((FILENAMELIST (UNPACKFILENAME FONTFILE))
           SIZEBEG SIZEND NAME FAMILY SIZE)
          (SETQ NAME (LISTGET FILENAMELIST 'NAME))           (* ; 
                                                           "find where the name and size are.")
          (SETQ SIZEBEG (for CH# from 1 when (NUMBERP (NTHCHAR NAME CH#))
                           do (RETURN CH#)))
          [SETQ FAMILY (MKATOM (SUBSTRING NAME 1 (SUB1 SIZEBEG]
          (SETQ SIZEND (for CH# from SIZEBEG when (NOT (NUMBERP (NTHCHAR NAME CH#)))
                          do (RETURN CH#)))
          [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
          (RETURN (LIST FAMILY SIZE (SELECTQ (LISTGET FILENAMELIST 'EXTENSION)
                                        ((DISPLAYFONT AC WD) 
                                             (LIST (COND
                                                      ((STRPOS "-B" NAME SIZEND NIL T)
                                                       'BOLD)
                                                      (T 'MEDIUM))
                                                   (COND
                                                      ((STRPOS "-I" NAME SIZEND NIL)
                                                       'ITALIC)
                                                      (T 'REGULAR))
                                                   'REGULAR))
                                        (LIST (COND
                                                 ((STRPOS "B" NAME SIZEND NIL T)
                                                  'BOLD)
                                                 (T 'MEDIUM))
                                              (COND
                                                 ((STRPOS "I" NAME SIZEND NIL)
                                                  'ITALIC)
                                                 (T 'REGULAR))
                                              'REGULAR))
                        0 DEVICE])

(\GETFONTDESC
  [LAMBDA (SPEC DEVICE NOERRORFLG)                       (* J.Gibbons " 5-Dec-82 16:53")

    (* ;; "Coerces SPEC to a fontdescriptor")
                                                             (* ; 
                                                "\GETFONTDESC HAS MACRO, BUT OLD CALLS STILL EXIST")
    (\COERCEFONTDESC SPEC DEVICE NOERRORFLG])

(\COERCEFONTDESC
  [LAMBDA (SPEC STREAM NOERRORFLG)                       (* ; "Edited 29-Aug-91 12:19 by jds")

    (* ;; "Coerces SPEC to a fontdescriptor appropriate for STREAM.  Go back thru FONTCREATE for various coercions in order to make sure that the cache gets set up")

    (DECLARE (GLOBALVARS DEFAULTFONT))
    (PROG (FONT DEVICE)
          [COND
             ((type? FONTDESCRIPTOR SPEC)
              (SETQ FONT SPEC))
             [(type? FONTCLASS SPEC)
              [SETQ DEVICE (COND
                              ((NULL STREAM)                 (* ; "Default is display")

                               (* ;; "COULDN'T THIS BRANCH BE INTENDED TO MEAN 4DISPLAY, 8DISPLAY, 24DISPLAY?  PEOPLE PROBABLY SHOULDN'T BE CALLING \COERCEFONTDESC WITH STREAM = NIL.")

                               'DISPLAY)
                              ((IMAGESTREAMP STREAM)
                               (IMAGESTREAMTYPE STREAM))
                              ((LITATOM STREAM)
                               (\DEVICESYMBOL STREAM))
                              (STREAM STREAM)
                              (T 
                                 (* ;; "I don't think this case should be allowed.")

                                 'DISPLAY]
              [SETQ FONT (SELECTQ DEVICE
                             (DISPLAY (fetch (FONTCLASS DISPLAYFD) of SPEC))
                             (INTERPRESS (fetch (FONTCLASS INTERPRESSFD) of SPEC))
                             (PRESS (fetch (FONTCLASS PRESSFD) of SPEC))
                             (CDR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of SPEC]
              (RETURN (COND
                         ((type? FONTDESCRIPTOR FONT)

                          (* ;; 
     "We don't always create FD's for devices before they are needed, so do it now and save result")

                          FONT)
                         [(NULL FONT)

                          (* ;; "NIL means create FONT but don't cache.")

                          (COND
                             ((AND (FMEMB DEVICE \DISPLAYSTREAMTYPES)
                                   (SETQ FONT (\COERCEFONTDESC SPEC 'DISPLAY NOERRORFLG))
                                   (SETQ FONT (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG))
                                   )

                              (* ;; 
                            "Coerce existing black & white font to color font, but don't cache.")

                              FONT)
                             [(EQ SPEC DEFAULTFONT)

                              (* ;; "Break cycles with NIL in the defaultfont")

                              (COND
                                 (NOERRORFLG NIL)
                                 ((EQ DEVICE 'DISPLAY)

                                  (* ;; "Function DEFAULTFONT guarantees system integrity")

                                  (DEFAULTFONT 'DISPLAY))
                                 ((EQUAL DEVICE '(HARDCOPY DISPLAY))

                                  (* ;; 
                "MAKE DISPLAY-HARDCOPY FONTS default to the corresponding display font, copied....")

                                  (FONTCOPY (DEFAULTFONT 'DISPLAY)
                                         'DEVICE STREAM 'NOERROR NOERRORFLG))
                                 (T (ERROR (CONCAT DEVICE " component for DEFAULTFONT undefined"]
                             (T (FONTCREATE DEFAULTFONT NIL NIL NIL STREAM NOERRORFLG]
                         ((SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM NOERRORFLG))

                          (* ;; "Might get NIL if NOERRORFLG")

                          (SETFONTCLASSCOMPONENT SPEC DEVICE FONT]
             ((NULL SPEC)
              (RETURN (\COERCEFONTDESC DEFAULTFONT STREAM NOERRORFLG)))
             ((OR (IMAGESTREAMP SPEC)
                  (type? WINDOW SPEC))
              (SETQ FONT (DSPFONT NIL SPEC)))
             (T 
                (* ;; "If called with NOERRORFLG=T (e.g.  from DSPFONT) we want to suppress invalid arg errors as well as font not found, so we can move on to other possible coercions.")

                (RETURN (FONTCREATE SPEC NIL NIL NIL STREAM NOERRORFLG]

     (* ;; "Here if arg was a fontdescriptor or imagestream")

          (RETURN (COND
                     ((NULL STREAM)

                      (* ;; 
                    "NIL device doesn't default to display if a fully-specified font was found")

                      FONT)
                     ([OR (EQ STREAM (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT))
                          (AND (type? STREAM STREAM)
                               (EQ (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM
                                                                                         IMAGEOPS)
                                                                                of STREAM))
                                   (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT]
                      FONT)
                     (T 
                        (* ;; "Here if doesn't match or if DEVICE is not explicitly a stream.")

                        (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG])

(\LOOKUPFONT
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)             (* ; "Edited 28-Jul-88 17:05 by rmk:")
                                                             (* ; "Edited 28-Jul-88 17:04 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:02 by rmk:")
                                                             (* ; "Edited 28-Jul-88 13:54 by rmk:")
                                                             (* ; "Edited 26-Feb-87 00:20 by FS")

    (* ;; "looks up a font in the internal cache.  SASSOC for listp FACE")

    (DECLARE (GLOBALVARS \FONTSINCORE))

    (* ;; "Someone had better have already made FACE canonical")

    (LET [(X (CDR (FASSOC ROTATION (CDR (SASSOC FACE (CDR (FASSOC SIZE (CDR (OR (FASSOC FAMILY 
                                                                                       \FONTSINCORE)
                                                                                (\FONT.SYMBOLASSOC
                                                                                 FAMILY \FONTSINCORE]
         (CDR (OR (FASSOC DEVICE X)
                  (\FONT.SYMBOLASSOC DEVICE X])

(\LOOKUPFONTSINCORE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)                 (* ; "Edited 25-Apr-93 13:07 by rmk:")
                                                             (* rrb "25-Sep-84 12:10")

(* ;;; "returns a list of the fonts that are available in core.  * is used to match anything.")

    (DECLARE (GLOBALVARS \FONTSINCORE))
    (for FAMBUCKET in \FONTSINCORE when (OR (EQ FAMILY '*)
                                                        (EQ FAMILY (CAR FAMBUCKET)))
       join (for SIZEBUCKET in (CDR FAMBUCKET) when (OR (EQ SIZE '*)
                                                                        (EQ SIZE (CAR SIZEBUCKET)))
                   join (for FACEBUCKET in (CDR SIZEBUCKET)
                               when (OR (EQ FACE '*)
                                            (EQUAL FACE (CAR FACEBUCKET)))
                               join (for ROTBUCKET in (CDR FACEBUCKET)
                                           when (OR (EQ ROTATION '*)
                                                        (EQ ROTATION (CAR ROTBUCKET)))
                                           join (for DEVBUCKET in (CDR ROTBUCKET)
                                                       when (AND (OR (EQ DEVICE '*)
                                                                         (EQ DEVICE (CAR DEVBUCKET)))
                                                                     (TYPE? FONTDESCRIPTOR
                                                                            (CDR DEVBUCKET)))
                                                       collect (LIST (CAR FAMBUCKET)
                                                                         (CAR SIZEBUCKET)
                                                                         (CAR FACEBUCKET)
                                                                         (CAR ROTBUCKET)
                                                                         (CAR DEVBUCKET])

(\READDISPLAYFONTFILE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)         (* ; "Edited  8-Oct-96 10:17 by rmk:")
                                                             (* ; 
                                                           "Edited 30-Sep-96 12:03 by kaplan")
                                                             (* ; "Edited  2-Jan-87 17:55 by FS")

    (* ;; "Look for new filename convention, then old file name convention, with extensions.   If CACHEDISPLAYFONTS, this keeps a cache of what was read, on the canonical filename's property list, so that NSDISPLAYSIZES and SMALLSCREEN size coercions can be done and undone without always going out to the directories.")

    (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES CACHEDISPLAYFONTS))
    (BIND FONTFILE CSINFO STRM
       FIRST 

             (* ;; "Cache is indexed by canonical font file name, without the extension fields.")

             (CL:WHEN 
                 [AND CACHEDISPLAYFONTS
                      (FIND EXT INSIDE DISPLAYFONTEXTENSIONS
                         SUCHTHAT (SETQ CSINFO
                                       (GETP (L-CASE (FILENAMEFIELD (IF (FMEMB EXT 
                                                                                *OLD-FONT-EXTENSIONS*
                                                                                   )
                                                                        THEN (\FONTFILENAME.OLD
                                                                                  FAMILY SIZE FACE 
                                                                                  EXT CHARSET)
                                                                      ELSE (\FONTFILENAME
                                                                                FAMILY SIZE FACE EXT
                                                                                CHARSET))
                                                            'NAME))
                                             'CACHEDCHARSET]
                 (RETURN (AND (NEQ CSINFO T)
                              (COPYALL CSINFO)))) FOR EXT INSIDE DISPLAYFONTEXTENSIONS
       WHEN (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET 
                                      DISPLAYFONTDIRECTORIES (LIST EXT)))
       DO 

             (* ;; 
          "Cache is indexed by canonical font file name, without the directory or extension fields")

             (SETQ STRM (OPENSTREAM FONTFILE 'INPUT))
             (RESETLST
                 [SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T)
                                  (STRIKE (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                                                               STRM))
                                          (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE))
                                  (AC 
                                      (* ;; "CLOSEF is guaranteed inside \READACFONTFILE, against the possibility that we have to copy to make randaccessp")

                                      (\READACFONTFILE STRM FAMILY SIZE FACE))
                                  (PROG1 (CLOSEF STRM)       (* ; 
"This would get done by RESETSAVE if AC's were read sequentially and we could factor the RESETSAVE")
                                      (SHOULDNT))])
             (CL:WHEN CACHEDISPLAYFONTS
                 (PUTPROP (L-CASE (FILENAMEFIELD FONTFILE 'NAME))
                        'CACHEDCHARSET CSINFO)
                 (SETQ CSINFO (COPYALL CSINFO))) 

             (* ;; "If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also be nice to tell the user that he has a bogus file.")

             (RETURN CSINFO)
       FINALLY 

             (* ;; "Didn't find the file, cache T to suppress future lookups")

             (CL:WHEN CACHEDISPLAYFONTS
                 (PUTPROP (L-CASE (FILENAMEFIELD (IF (FMEMB (CAR (MKLIST DISPLAYFONTEXTENSIONS))
                                                                *OLD-FONT-EXTENSIONS*)
                                                     THEN (\FONTFILENAME.OLD
                                                               FAMILY SIZE FACE (CAR (MKLIST 
                                                                                DISPLAYFONTEXTENSIONS
                                                                                            ))
                                                               CHARSET)
                                                   ELSE (\FONTFILENAME FAMILY SIZE FACE
                                                                   (CAR (MKLIST DISPLAYFONTEXTENSIONS
                                                                               ))
                                                                   CHARSET))
                                         'NAME))
                        'CACHEDCHARSET T))])
)



(* ;; 
"\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories.  That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places.  "
)


(ADDTOVAR *OLD-FONT-EXTENSIONS* STRIKE)

(RPAQ? *USEOLDFONTDIRECTORIES* NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)
)



(* ;; 
"Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)"
)




(* ;; 
"Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)"
)


(RPAQ? CACHEDISPLAYFONTS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS CACHEDISPLAYFONTS)
)



(* ; "STRIKE format file support")

(DEFINEQ

(\READSTRIKEFONTFILE
  [LAMBDA (STRM FAMILY SIZE FACE)                        (* ; "Edited  4-Dec-92 12:11 by jds")
                                                             (* ; 
                             "STRM has already been determined to be a vanilla strike-format file.")
                                                             (* ; "returns a charsetinfo")
    (COND
       ((NEQ 2 (GETFILEPTR STRM))
        (SETFILEPTR STRM 2)))
    (PROG (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
          (SETQ CSINFO (create CHARSETINFO))
          (SETQ FIRSTCHAR (\WIN STRM))                       (* ; "minimum ascii code")
          (SETQ LASTCHAR (\WIN STRM))                        (* ; "maximum ascii code")
          (\WIN STRM)                                        (* ; 
                                                           "MaxWidth which isn't used by anyone.")
          (\WIN STRM)                                        (* ; 
                                                           "number of words in this StrikeBody")
          (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM))
                                                             (* ; 
                                                           "ascent in scan lines (=FBBdy+FBBoy)")
          (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM))
                                                             (* ; "descent in scan-lines (=FBBoy)")
          (\WIN STRM)                                        (* ; 
                                                  "offset in bits (<0 for kerning, else 0, =FBBox)")
          (SETQ RW (\WIN STRM))                              (* ; "raster width of bitmap")
                                                             (* ; "height of bitmap")

     (* ;; "JDS 12/4/92:  Apparently, these fields can be signed values, if all chars, e.g., ride above the base line.")

          (SETQ HEIGHT (IPLUS (SIGNED (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                                     16)
                              (SIGNED (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)
                                     16)))
          (SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
                              HEIGHT))
          (\BINS STRM (fetch BITMAPBASE of BITMAP)
                 0
                 (UNFOLD (ITIMES RW HEIGHT)
                        BYTESPERWORD))                       (* ; "read bits into bitmap")
          (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)
          (SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR)
                                 3))                         (* (SETQ OFFSETS (ARRAY
                                                           (IPLUS \MAXCHAR 3)
                                                           (QUOTE SMALLPOSP) 0 0)))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
                                                             (* ; "initialise the offsets to 0")
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0))
                                                             (* (AIN OFFSETS FIRSTCHAR NUMBCODES 
                                                           STRM))
          (for I from FIRSTCHAR as J from 1 to NUMBCODES
             do (\FSETOFFSET OFFSETS I (\WIN STRM)))
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0))
                                                             (* (replace WIDTHS of
                                                           (CHARSETINFO CSINFO) with
                                                           (ARRAY (IPLUS \MAXCHAR 3)
                                                           (QUOTE SMALLPOSP) 0 0)))
          (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
          (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO
                                                                                    WIDTHS)
                                                                           of CSINFO))
          (RETURN CSINFO])

(\SFMAKEBOLD
  [LAMBDA (CSINFO)                                       (* gbn "25-Jul-85 04:52")
    (PROG* ((OLDCHARBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
            (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
            (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
            (HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                           (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
            NEWCHARBITMAP OFFSET UNKNOWNOFFSET UNKNOWNWIDTH)
           (SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP)
                                      (fetch BITMAPHEIGHT of OLDCHARBITMAP)))
           (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXCHAR)))
           (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXCHAR)))
           [for I from 0 to \MAXCHAR
              do (COND
                        ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                             UNKNOWNOFFSET)                  (* ; 
             "if this is the magic charcode with the slug image (charcode 256) then leave it alone")
                         NIL)
                        (T                                   (* ; 
                                                          "overlap two blts to produce bold effect")
                           (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP OFFSET 0 (\FGETWIDTH WIDTHS I
                                                                                        )
                                  HEIGHT
                                  'INPUT
                                  'REPLACE)
                           (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP (ADD1 OFFSET)
                                  0
                                  (SUB1 (\FGETWIDTH WIDTHS I))
                                  HEIGHT
                                  'INPUT
                                  'PAINT]                    (* ; 
                                                          "fill in the slug for the magic charcode")
           (BITBLT OLDCHARBITMAP UNKNOWNOFFSET 0 NEWCHARBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
                  'INPUT
                  'REPLACE)
           (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWCHARBITMAP])

(\SFMAKEITALIC
  [LAMBDA (CSINFO)                                       (* gbn "18-Sep-85 17:57")
    (PROG ((WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
           (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
           (ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
           (DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
           (OLDBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
           HEIGHT OFFSET NEWBITMAP WIDTH UNKNOWNOFFSET UNKNOWNWIDTH N M R XN XX YN YX)
          (SETQ HEIGHT (IPLUS ASCENT DESCENT))
          (SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP)
                                 (fetch BITMAPHEIGHT of OLDBITMAP)))
          (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR)))
          (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR)))
          (SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3)
                                        4)))
          (SETQ M (IQUOTIENT (IPLUS ASCENT 3)
                         4))
          [for I from 0 to \MAXTHINCHAR
             do (COND
                       ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                            UNKNOWNOFFSET)                   (* ; 
             "if this is the magic charcode with the slug image (charcode 256) then leave it alone")
                        NIL)
                       (T (SETQ WIDTH (\FGETWIDTH WIDTHS I))
                          (for J from N to M
                             do (SETQ R (IPLUS OFFSET WIDTH))
                                   (SETQ XN (IMIN R (IMAX (IPLUS OFFSET J)
                                                          0)))
                                   (SETQ XX (IMIN R (IMAX (IPLUS R J)
                                                          0)))
                                   [SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4]
                                   [SETQ YX (IMIN HEIGHT (IPLUS DESCENT (IPLUS (ITIMES J 4)
                                                                               4]
                                   (COND
                                      ((AND (IGREATERP XX XN)
                                            (IGREATERP YX YN))
                                       (BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN (IDIFFERENCE
                                                                                    XX XN)
                                              (IDIFFERENCE YX YN)
                                              'INPUT
                                              'REPLACE]
          (BITBLT OLDBITMAP UNKNOWNOFFSET 0 NEWBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
                 'INPUT
                 'REPLACE)
          (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWBITMAP])

(\SFMAKEROTATEDFONT
  [LAMBDA (FONTDESC ROTATION)                            (* ; "Edited 30-Mar-87 20:35 by FS")

    (* ;; "takes a fontdecriptor and rotates it.")

    (* ;; "1/5/86 JDS.  Masterscope claims nobody calls this.  Let's find out....")

    (HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields")
                                                             (* (create FONTDESCRIPTOR using 
                                                           FONTDESC (SETQ CHARACTERBITMAP
                                                           (\SFROTATEFONTCHARACTERS
                                                           (fetch (FONTDESCRIPTOR 
                                                           CHARACTERBITMAP) of FONTDESC) 
                                                           ROTATION)) (SETQ ROTATION ROTATION)
                                                           (SETQ \SFOffsets (
                                                           \SFFIXOFFSETSAFTERROTATION FONTDESC 
                                                           ROTATION)) (SETQ FONTCHARSETVECTOR
                                                           (\ALLOCBLOCK (ADD1 \MAXCHARSET) T))))

    (* ;; "If you uncomment out the code above, remove this comment and the NIL below")

    NIL])

(\SFROTATECSINFO
  [LAMBDA (CSINFO ROTATION)                              (* gbn "15-Sep-85 14:38")

    (* ;; "takes a CHARSETINFO and rotates it and produces a rotated equivalent one.")

    (create CHARSETINFO using CSINFO CHARSETBITMAP _ (\SFROTATEFONTCHARACTERS
                                                              (fetch (CHARSETINFO CHARSETBITMAP)
                                                                 of CSINFO)
                                                              ROTATION)
                                  OFFSETS _ (\SFROTATECSINFOOFFSETS CSINFO ROTATION])

(\SFROTATEFONTCHARACTERS
  [LAMBDA (CHARBITMAP ROTATION)                          (* ; "Edited 22-Sep-87 10:38 by Snow")

(* ;;; "rotate a bitmap either 90 or 270 for fonts.")

    (CASE ROTATION
        (0 CHARBITMAP)
        (90 (ROTATE-BITMAP-LEFT CHARBITMAP))
        (180 (ROTATE-BITMAP (ROTATE-BITMAP CHARBITMAP)))
        (270 (ROTATE-BITMAP CHARBITMAP)))])

(\SFFIXOFFSETSAFTERROTATION
  [LAMBDA (FONTDESC ROTATION)                            (* ; "Edited 30-Mar-87 20:35 by FS")

    (* ;; "adjusts offsets in case where rotation turned things around.")

    (HELP "NEED TO UPDATE THIS FN TO NSCHARS & NEW FONT FIELDS")
                                                             (* (COND ((EQ ROTATION 270)
                                                           (PROG ((OFFSETS (fetch
                                                           (FONTDESCRIPTOR \SFOffsets) of 
                                                           FONTDESC)) (WIDTHS
                                                           (fetch (FONTDESCRIPTOR \SFWidths) of 
                                                           FONTDESC)) (BITMAPHEIGHT
                                                           (BITMAPWIDTH (fetch
                                                           (FONTDESCRIPTOR CHARACTERBITMAP) of 
                                                           FONTDESC))) NEWOFFSETS)
                                                           (SETQ NEWOFFSETS (COPYARRAY OFFSETS))
                                                           (for CHARCODE from 0 to \MAXCHAR do
                                                           (SETA NEWOFFSETS CHARCODE
                                                           (IDIFFERENCE BITMAPHEIGHT
                                                           (IPLUS (ELT OFFSETS CHARCODE)
                                                           (ELT WIDTHS CHARCODE)))))
                                                           (* ; 
                                         "may be some problem with dummy character representation.")
                                                           (RETURN NEWOFFSETS)))
                                                           (T (fetch (FONTDESCRIPTOR \SFOffsets)
  of FONTDESC))))

    (* ;; "If you uncomment out the code above, remove this comment and the NIL below")

    NIL])

(\SFROTATECSINFOOFFSETS
  [LAMBDA (CSINFO ROTATION)                              (* gbn "15-Sep-85 14:36")
                                                             (* ; 
                                     "adjusts offsets in case where rotation turned things around.")
    (COND
       ((EQ ROTATION 270)
        (PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
               (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
               (BITMAPHEIGHT (BITMAPWIDTH (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)))
               NEWOFFSETS)
              (SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
              [for CHARCODE from 0 to \MAXCHAR
                 do (\FSETOFFSET NEWOFFSETS CHARCODE (IDIFFERENCE BITMAPHEIGHT
                                                                (IPLUS (\FGETOFFSET OFFSETS CHARCODE)
                                                                       (\FGETWIDTH WIDTHS CHARCODE]
                                                             (* ; 
                                         "may be some problem with dummy character representation.")
              (RETURN NEWOFFSETS)))
       (T (fetch (CHARSETINFO OFFSETS) of CSINFO])

(\SFMAKECOLOR
  [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL)    (* kbr%: " 6-Feb-86 18:17")

    (* ;; "makes a csinfo that has a character bitmap that is colorized.")

    (PROG (CHARACTERBITMAP COLORCSINFO)
          [COND
             ((IMAGESTREAMP BITSPERPIXEL)
              (OR BACKCOLOR (SETQ BACKCOLOR (DSPBACKCOLOR NIL BITSPERPIXEL)))
              (OR FORECOLOR (SETQ FORECOLOR (DSPCOLOR NIL BITSPERPIXEL)))
              (SETQ BITSPERPIXEL (IMAGESTREAMTYPE BITSPERPIXEL]
          [SETQ BITSPERPIXEL (COND
                                ((NUMBERP BITSPERPIXEL)
                                 BITSPERPIXEL)
                                (T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL]
          (SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL))
          (SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL))
          (SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of 
                                                                                             BWCSINFO
                                                       )
                                       BACKCOLOR FORECOLOR BITSPERPIXEL))
          (SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP _ 
                                                          CHARACTERBITMAP))
          (RETURN COLORCSINFO])
)
(DEFINEQ

(WRITESTRIKEFONTFILE
  [LAMBDA (FONT CHARSET FILENAME)                        (* ; "Edited 30-Mar-87 20:25 by FS")

    (* ;; "Write strike FILE using info in FONT, AND CHARSET number.")

    (* ;; "This code only works if original file was STRIKE.  Otherwise, a new CSINFO is dummied up and it is used instead.  So, CSINFO when read in might be different than the one written out.")

    (PROG (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTHS OFFSETS IMWIDTHS MAXWIDTH RASTERWIDTH LENGTH 
                 DUMMYCHAR DUMMYOFFSET DUMMYINDEX WIDTH OFFSET CODE MAXCODE)
          (SETQ MAXCODE 255)                                 (* ; "Max charcode")
          (SETQ DUMMYINDEX 256)                              (* ; "Dummy char marker")
          (COND
             ((NOT (FONTP FONT))
              (LISPERROR "ILLEGAL ARG" FONT)))
          (COND
             ((NULL CHARSET)
              (SETQ CHARSET 0))
             ((NOT (AND (IGEQ CHARSET 0)
                        (ILESSP CHARSET \MAXCHARSET)))
              (LISPERROR "ILLEGAL ARG" CHARSET)))
          (SETQ CSINFO (STRIKECSINFO (\GETCHARSETINFO CHARSET FONT T)))
                                                             (* ; 
                                                           "Guarantee its a STRIKE font CSINFO.")
          (COND
             ((NULL CSINFO)
              (ERROR "Couldn't find charset " CHARSET)))
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
          (SETQ IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))

     (* ;; "Index 256 contains a dummy width; use it's value to determine missing chars")

          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX))
          [SETQ FIRSTCHAR (for I from 0 to MAXCODE
                             thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
                                                  DUMMYOFFSET]
          [SETQ LASTCHAR (for I from MAXCODE to 0 by -1
                            thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
                                                 DUMMYOFFSET]
          (SETQ DUMMYCHAR (ADD1 LASTCHAR))
          [SETQ STREAM (OPENSTREAM FILENAME 'OUTPUT 'NEW '((TYPE BINARY]

     (* ;; "")

     (* ;; "STRIKE Header")

     (* ;; "")

          (\WOUT STREAM 32768)
          (\WOUT STREAM FIRSTCHAR)
          (\WOUT STREAM LASTCHAR)
          (SETQ MAXWIDTH 0)
          [for I from 0 to DUMMYINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH
                                                                              (\FGETWIDTH WIDTHS I]
          (\WOUT STREAM MAXWIDTH)

     (* ;; "")

     (* ;; "STRIKE Body")

     (* ;; "")

     (* ;; "Length of body")

          (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (CHARSETINFO
                                                                                     CHARSETBITMAP)
                                                                            of CSINFO)))
          (SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR)
                              (ITIMES (fetch (FONTDESCRIPTOR \SFHeight) of FONT)
                                     RASTERWIDTH)))
          (\WOUT STREAM LENGTH)

     (* ;; "Ascent, Descent, Xoffset (no longer used) and Rasterwidth.")

          (\WOUT STREAM (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
          (\WOUT STREAM (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
          (\WOUT STREAM 0)                                   (* ; 
                                                  "offset in bits (<0 for kerning, else 0, =FBBox)")
          (\WOUT STREAM RASTERWIDTH)

     (* ;; "Bitmap")

          [\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (CHARSETINFO CHARSETBITMAP)
                                                                  of CSINFO))
                 0
                 (ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                                              (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]

     (* ;; "Offsets")

          (SETQ CODE 0)
          (\WOUT STREAM CODE)
          (for I from FIRSTCHAR to DUMMYCHAR
             do (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                   (SETQ WIDTH (\FGETWIDTH WIDTHS I))
                   [COND
                      ((AND (IEQP OFFSET DUMMYOFFSET)
                            (NOT (IEQP I DUMMYCHAR)))        (* ; "CODE stays the same.")
                       )
                      (T (SETQ CODE (IPLUS CODE WIDTH]
                   (\WOUT STREAM CODE))
          (CLOSEF STREAM])

(STRIKECSINFO
  [LAMBDA (CSINFO)                                       (* ; "Edited 27-Apr-89 13:39 by atm")

    (* ;; "Returns a STRIKE type font descriptor (EQ WIDTHS IMAGEWIDTHS), cause we know how to write those guys out (they read quicker  but display slower).  If (EQ WIDTHS IMAGEWIDTHS), just return original.")

    (PROG (WIDTHS OFFSETS IMWIDTHS OLDBM BMWIDTH BMHEIGHT NEWBM NEWOFFSET NEWWIDTH OLDOFFSET 
                 DUMMYOFFSET NEWOFFSETS)
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (SETQ IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))
          (if (EQ WIDTHS IMWIDTHS)
              then (RETURN CSINFO))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
          (SETQ OLDBM (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS 256))
          (SETQ BMHEIGHT (BITMAPHEIGHT OLDBM))
          [SETQ BMWIDTH (for I from 0 to \MAXTHINCHAR
                           sum (if (IEQP DUMMYOFFSET (\FGETOFFSET OFFSETS I))
                                       then 0
                                     else (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
                                                    (\FGETWIDTH WIDTHS I]

     (* ;; "")

     (* ;; "Initialize new offsets vector")

     (* ;; "")

          (SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET NEWOFFSETS I 0))
          (\FSETOFFSET NEWOFFSETS (ADD1 \MAXTHINCHAR)
                 BMWIDTH)

     (* ;; "")

     (* ;; "Adjust bitmap with so width = imagewidth, fill offsets")

     (* ;; "")

          (SETQ NEWBM (BITMAPCREATE BMWIDTH BMHEIGHT 1))
          (SETQ NEWOFFSET 0)
          [for I from 0 to 255
             do (SETQ OLDOFFSET (\FGETOFFSET OFFSETS I))
                   (if (IEQP DUMMYOFFSET OLDOFFSET)
                       then (\FSETOFFSET NEWOFFSETS I BMWIDTH)
                     else (\FSETOFFSET NEWOFFSETS I NEWOFFSET)
                           (SETQ NEWWIDTH (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
                                                (\FGETWIDTH WIDTHS I)))
                           (BITBLT OLDBM OLDOFFSET 0 NEWBM NEWOFFSET 0 (\FGETWIDTH IMWIDTHS I)
                                  BMHEIGHT
                                  'REPLACE)
                           (SETQ NEWOFFSET (IPLUS NEWOFFSET NEWWIDTH]

     (* ;; "")

     (* ;; "Make new CSInfo record withs IMAGEWIDTHS, WIDTHS the same")

     (* ;; "")

          (SETQ WIDTHS (COPYALL WIDTHS))
          [for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I
                                                                  (IMAX (\FGETWIDTH WIDTHS I)
                                                                        (\FGETIMAGEWIDTH IMWIDTHS I]
          (RETURN (create CHARSETINFO
                         WIDTHS _ WIDTHS
                         OFFSETS _ NEWOFFSETS
                         IMAGEWIDTHS _ WIDTHS
                         CHARSETBITMAP _ NEWBM
                         YWIDTHS _ (fetch (CHARSETINFO YWIDTHS) of CSINFO)
                         CHARSETASCENT _ (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                         CHARSETDESCENT _ (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO])
)

(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
       '((FONTCLASS 0 (BITS . 7))
         (FONTCLASS 2 POINTER)
         (FONTCLASS 4 POINTER)
         (FONTCLASS 6 POINTER)
         (FONTCLASS 8 POINTER)
         (FONTCLASS 10 POINTER))
       '12)

(/DECLAREDATATYPE 'FONTDESCRIPTOR
       '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD 
               SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 2 POINTER)
         (FONTDESCRIPTOR 4 POINTER)
         (FONTDESCRIPTOR 6 POINTER)
         (FONTDESCRIPTOR 8 (BITS . 15))
         (FONTDESCRIPTOR 9 (BITS . 15))
         (FONTDESCRIPTOR 10 (BITS . 15))
         (FONTDESCRIPTOR 11 (BITS . 15))
         (FONTDESCRIPTOR 12 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 13 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 14 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 15 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 16 POINTER)
         (FONTDESCRIPTOR 18 POINTER)
         (FONTDESCRIPTOR 20 POINTER)
         (FONTDESCRIPTOR 22 POINTER)
         (FONTDESCRIPTOR 24 POINTER)
         (FONTDESCRIPTOR 26 (BITS . 7))
         (FONTDESCRIPTOR 27 (BITS . 15))
         (FONTDESCRIPTOR 28 POINTER)
         (FONTDESCRIPTOR 30 POINTER)
         (FONTDESCRIPTOR 32 POINTER))
       '34)

(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)
       '((CHARSETINFO 0 POINTER)
         (CHARSETINFO 2 POINTER)
         (CHARSETINFO 4 POINTER)
         (CHARSETINFO 6 POINTER)
         (CHARSETINFO 8 POINTER)
         (CHARSETINFO 10 (BITS . 15))
         (CHARSETINFO 11 (BITS . 15))
         (CHARSETINFO 12 POINTER))
       '14)
(ADDTOVAR SYSTEMRECLST

(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
                         DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))

(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
                              (FONTFAMILY POINTER)
                              (FONTSIZE POINTER)
                              (FONTFACE POINTER)
                              (\SFAscent WORD)
                              (\SFDescent WORD)
                              (\SFHeight WORD)
                              (ROTATION WORD)
                              (FBBOX SIGNEDWORD)
                              (FBBOY SIGNEDWORD)
                              (FBBDX SIGNEDWORD)
                              (FBBDY SIGNEDWORD)
                              (\SFLKerns POINTER)
                              (\SFRWidths POINTER)
                              (FONTDEVICESPEC POINTER)
                              (OTHERDEVICEFONTPROPS POINTER)
                              (FONTSCALE POINTER)
                              (\SFFACECODE BITS 8)
                              (FONTAVGCHARWIDTH WORD)
                              (FONTIMAGEWIDTHS POINTER)
                              (FONTCHARSETVECTOR POINTER)
                              (FONTEXTRAFIELD2 POINTER)))

(DATATYPE CHARSETINFO (WIDTHS OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD)
                                 (CHARSETDESCENT WORD)
                                 LEFTKERN))
)

(RPAQ? \FONTSINCORE )

(RPAQ? \DEFAULTDEVICEFONTS )

(RPAQ? \UNITWIDTHSVECTOR )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\UNITWIDTHSVECTOR)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ NORUNCODE 255)


(CONSTANTS (NORUNCODE 255))
)
(* "FOLLOWING DEFINITIONS EXPORTED")
(DEFOPTIMIZER FONTPROP (&REST ARGS)
                           (SELECTQ (AND (EQ (CAADR ARGS)
                                             'QUOTE)
                                         (CADADR ARGS))
                               (ASCENT (LIST 'FONTASCENT (CAR ARGS)))
                               (DESCENT (LIST 'FONTDESCENT (CAR ARGS)))
                               (HEIGHT (LIST 'FONTHEIGHT (CAR ARGS)))
                               'IGNOREMACRO))

(* "END EXPORTED DEFINITIONS")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE

(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
                         DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))

(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
                              (FONTFAMILY POINTER)
                              (FONTSIZE POINTER)
                              (FONTFACE POINTER)
                              (\SFAscent WORD)
                              (\SFDescent WORD)
                              (\SFHeight WORD)
                              (ROTATION WORD)
                              (FBBOX SIGNEDWORD)
                              (FBBOY SIGNEDWORD)
                              (FBBDX SIGNEDWORD)
                              (FBBDY SIGNEDWORD)
                              (\SFLKerns POINTER)
                              (\SFRWidths POINTER)
                              (FONTDEVICESPEC POINTER)       (* ; 
      "Holds the spec by which the font is known to the printing device, if coercion has been done")
                              (OTHERDEVICEFONTPROPS POINTER) (* ; 
                                               "For individual devices to hang special information")
                              (FONTSCALE POINTER)
                              (\SFFACECODE BITS 8)
                              (FONTAVGCHARWIDTH WORD)        (* ; 
                          "Set in FONTCREATE, used to fix up the linelength when DSPFONT is called")
                              (FONTIMAGEWIDTHS POINTER)      (* ; "This is the image width, as opposed to the advanced width;  initial hack for accents, kerning.  Fields is referenced by FONTCREATE.")
                              (FONTCHARSETVECTOR POINTER)    (* ; "A 256-pointer block, with one pointer per 'character set' --each group of 256 character codes.  Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset.")
                              (FONTEXTRAFIELD2 POINTER))
                             FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR))

(RECORD FONTFACE (WEIGHT SLOPE EXPANSION)
                     [ACCESSFNS ((COLOR (CDDDR DATUM)
                                        (RPLACD (CDDR DATUM)
                                               NEWVALUE))
                                 (BACKCOLOR [COND
                                               ((CDDDR DATUM)
                                                (CAR (CDDDR DATUM]
                                        (PROGN [COND
                                                  ((NULL (CDDDR DATUM))
                                                   (RPLACD (CDDR DATUM)
                                                          (LIST NIL NIL]
                                               (RPLACA (CDDDR DATUM)
                                                      NEWVALUE)))
                                 (FORECOLOR [COND
                                               ((CDDDR DATUM)
                                                (CADR (CDDDR DATUM]
                                        (PROGN [COND
                                                  ((NULL (CDDDR DATUM))
                                                   (RPLACD (CDDR DATUM)
                                                          (LIST NIL NIL]
                                               (RPLACA (CDR (CDDDR DATUM))
                                                      NEWVALUE]
                     WEIGHT _ 'MEDIUM SLOPE _ 'REGULAR EXPANSION _ 'REGULAR (TYPE? LISTP))

(DATATYPE CHARSETINFO (WIDTHS                            (* ; "The advance-width of each character, an array indexed by charcode.  Usually the same as the imagewidth, but can differ for accents, kerns kerns.  This is what should be used for stringwidth calculations.")
                                 OFFSETS                     (* ; 
                            "Offset of each character into the image bitmap;  X value of left edge")
                                 IMAGEWIDTHS                 (* ; 
                         "imagewidths is not automagically allocated since it is not always needed")
                                 CHARSETBITMAP               (* ; 
                                       "Bitmap containing the character images, indexed by OFFSETS")
                                 YWIDTHS
                                 (CHARSETASCENT WORD)        (* ; 
                                                    "Max ascent for all characters in this CHARSET")
                                 (CHARSETDESCENT WORD)       (* ; 
                                                   "Max descent for all characters in this CHARSET")
                                 LEFTKERN)
                          WIDTHS _ (\CREATECSINFOELEMENT)
                          OFFSETS _ (\CREATECSINFOELEMENT))
)

(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
       '((FONTCLASS 0 (BITS . 7))
         (FONTCLASS 2 POINTER)
         (FONTCLASS 4 POINTER)
         (FONTCLASS 6 POINTER)
         (FONTCLASS 8 POINTER)
         (FONTCLASS 10 POINTER))
       '12)

(/DECLAREDATATYPE 'FONTDESCRIPTOR
       '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD 
               SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 2 POINTER)
         (FONTDESCRIPTOR 4 POINTER)
         (FONTDESCRIPTOR 6 POINTER)
         (FONTDESCRIPTOR 8 (BITS . 15))
         (FONTDESCRIPTOR 9 (BITS . 15))
         (FONTDESCRIPTOR 10 (BITS . 15))
         (FONTDESCRIPTOR 11 (BITS . 15))
         (FONTDESCRIPTOR 12 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 13 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 14 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 15 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 16 POINTER)
         (FONTDESCRIPTOR 18 POINTER)
         (FONTDESCRIPTOR 20 POINTER)
         (FONTDESCRIPTOR 22 POINTER)
         (FONTDESCRIPTOR 24 POINTER)
         (FONTDESCRIPTOR 26 (BITS . 7))
         (FONTDESCRIPTOR 27 (BITS . 15))
         (FONTDESCRIPTOR 28 POINTER)
         (FONTDESCRIPTOR 30 POINTER)
         (FONTDESCRIPTOR 32 POINTER))
       '34)

(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)
       '((CHARSETINFO 0 POINTER)
         (CHARSETINFO 2 POINTER)
         (CHARSETINFO 4 POINTER)
         (CHARSETINFO 6 POINTER)
         (CHARSETINFO 8 POINTER)
         (CHARSETINFO 10 (BITS . 15))
         (CHARSETINFO 11 (BITS . 15))
         (CHARSETINFO 12 POINTER))
       '14)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS FONTASCENT MACRO ((FONTSPEC)
                                    (ffetch \SFAscent of (\GETFONTDESC FONTSPEC))))

(PUTPROPS FONTDESCENT MACRO ((FONTSPEC)
                                     (ffetch \SFDescent of (\GETFONTDESC FONTSPEC))))

(PUTPROPS FONTHEIGHT MACRO ((FONTSPEC)
                                    (ffetch \SFHeight of (\GETFONTDESC FONTSPEC))))

(PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE)
                                      (\GETBASE OFFSETSBLOCK CHAR8CODE)))

(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET)
                                      (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET)))

(PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE)
                                     (\GETBASE WIDTHSBLOCK CHAR8CODE)))

(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
                                     (\PUTBASE WIDTHSBLOCK INDEX WIDTH)))

(PUTPROPS \FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE)
                                         (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS)
                                                        of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                      FONTDESC))
                                                (\CHAR8CODE CHARCODE))))

(PUTPROPS \FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH)
                                         (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS)
                                                        of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                      FONTDESC))
                                                (\CHAR8CODE CHARCODE)
                                                WIDTH)))

(PUTPROPS \FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE)
                                         (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE)))

(PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
                                          (\PUTBASE WIDTHSBLOCK INDEX WIDTH)))

(PUTPROPS \GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?)

                                         (* ;; "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC.  If NIL, then creates the required charset.")

                                         (* ;; 
  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")

                                         (OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of 
                                                                                             FONTDESC
                                                                 )
                                                    (UNFOLD CHARSET 2))
                                             (\CREATECHARSET CHARSET FONTDESC NOSLUG?))))

(PUTPROPS \CREATECSINFOELEMENT MACRO (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3)
                                                                      WORDSPERCELL))))

(PUTPROPS \CREATEFONTCHARSETVECTOR MACRO (NIL        (* ; 
                                                  "Allocates a block for the character set records")
                                                      (\ALLOCBLOCK (ADD1 \MAXCHARSET)
                                                             T)))
)

(DEFMACRO \CREATEKERNELEMENT ()
   `(CL:MAKE-ARRAY (IPLUS \MAXTHINCHAR 3)
           :ELEMENT-TYPE
           '(SIGNED-BYTE 16)
           :INITIAL-ELEMENT 0))

(DEFMACRO \FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE)
   `(CL:SETF (CL:AREF ,LEFTKERNBLOCK ,INDEX)
           ,KERNVALUE))

(DEFMACRO \FGETLEFTKERN (LEFTKERNBLOCK CHAR8CODE)
   `(CL:AREF ,LEFTKERNBLOCK ,CHAR8CODE))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAXNSCHAR 65535)


(CONSTANTS (\MAXNSCHAR 65535))
)

(* "END EXPORTED DEFINITIONS")

)



(* ; "NS Character specific code")

(DEFINEQ

(\CREATECHARSET
  [LAMBDA (CHARSET FONT NOSLUG?)                         (* ; "Edited  8-May-93 23:42 by rmk:")
                                                             (* ; "Edited  4-Dec-92 11:43 by jds")

    (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR")
                                                             (* ; 
  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")
    (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES))
    (AND (IGREATERP CHARSET \MAXCHARSET)
         (\ILLEGAL.ARG CHARSET))
    (PROG [CSINFO (CREATEFN (COND
                               ((FMEMB (FONTPROP FONT 'DEVICE)
                                       \DISPLAYSTREAMTYPES)
                                (FUNCTION \CREATECHARSET.DISPLAY))
                               (T (CADR (ASSOC 'CREATECHARSET (CDR (ASSOC (FONTPROP FONT
                                                                                 'DEVICE)
                                                                          IMAGESTREAMTYPES]

     (* ;; "Create a descriptor of info for that charset, and use it to fill things in.")

          (COND
             ([NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC)
                                                       (LIST CHARSET FONT NOSLUG?]
                                                             (* ; 
                                               "the create method returned NIL--NOSLUG? must be T.")
              (RETURN NIL)))
          (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT)
                                                            (SIGNED (fetch CHARSETASCENT
                                                                       of CSINFO)
                                                                   16)))
          (replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT)
                                                             (SIGNED (ffetch CHARSETDESCENT
                                                                        of CSINFO)
                                                                    16)))
          (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent of FONT)
                                                             (ffetch \SFDescent of FONT)))
                                                             (* ; 
                              "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")
          (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
                         CHARSET CSINFO])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS 
       CHARSETERRORFLG)
)

(RPAQ? DISPLAYFONTCOERCIONS NIL)

(RPAQ? MISSINGCHARSETDISPLAYFONTCOERCIONS
       '(((GACHA)
          (TERMINAL))
         ((MODERN)
          (CLASSIC))
         ((TIMESROMAN)
          (CLASSIC))
         ((HELVETICA)
          (MODERN))
         ((TERMINAL 6)
          (MODERN 6))
         ((TERMINAL 8)
          (MODERN 8))
         ((TERMINAL 10)
          (MODERN 10))
         ((TERMINAL 12)
          (MODERN 12))))

(RPAQ? MISSINGDISPLAYFONTCOERCIONS '(((GACHA)
                                          (TERMINAL))
                                         ((MODERN)
                                          (CLASSIC))
                                         ((TIMESROMAN)
                                          (CLASSIC))
                                         ((HELVETICA)
                                          (MODERN))))

(RPAQ? CHARSETERRORFLG NIL)

(RPAQ? \DEFAULTCHARSET 0)
(DEFINEQ

(\FONTRESETCHARWIDTHS
  [LAMBDA (CSINFO FIRSTCHAR LASTCHAR)                    (* AJB " 6-Dec-85 14:42")
                                                             (* ; 
                                                     "sets the widths array from the offsets array")
    (PROG ((mincharcode FIRSTCHAR)
           (maxcharcode LASTCHAR)
           (offsets (fetch (CHARSETINFO OFFSETS) of CSINFO))
           (widths (fetch (CHARSETINFO WIDTHS) of CSINFO))
           left right charoffset dummycharoffset dummycharwidth)
          (SETQ dummycharoffset (\FGETOFFSET offsets (ADD1 maxcharcode)))
          (SETQ dummycharwidth (IDIFFERENCE (\FGETOFFSET offsets (IPLUS maxcharcode 2))
                                      dummycharoffset))
          [for charcode from 0 to \MAXCHAR
             do (COND
                       ((OR (ILESSP charcode mincharcode)
                            (IGREATERP charcode maxcharcode))
                        (\FSETOFFSET offsets charcode dummycharoffset)
                        (\FSETWIDTH widths charcode dummycharwidth))
                       (T (SETQ left (\FGETWIDTH offsets charcode))
                          (SETQ right (\FGETWIDTH offsets (ADD1 charcode)))
                          (COND
                             ((EQ left right)
                              (\FSETOFFSET offsets charcode dummycharoffset)
                              (\FSETWIDTH widths charcode dummycharwidth))
                             (T (\FSETWIDTH widths charcode (IDIFFERENCE right left]
          (\FSETWIDTH widths (ADD1 \MAXCHAR)
                 dummycharwidth)
          (\FSETOFFSET offsets (ADD1 \MAXCHAR)
                 dummycharoffset])
)
(DECLARE%: DONTEVAL@LOAD 

(RPAQ? DISPLAYFONTEXTENSIONS 'DISPLAYFONT)

(RPAQ? DISPLAYFONTDIRECTORIES '({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ 
                                          {dsk}/usr/local/lde/fonts/display/publishing/))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \FGETCHARIMAGEWIDTH MACRO (OPENLAMBDA (FONT CHARCODE)
                                              (\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS)
                                                             of (\GETCHARSETINFO (\CHARSET 
                                                                                            CHARCODE)
                                                                           FONT))
                                                     (\CHAR8CODE CHARCODE))))

(PROGN (PUTPROPS \GETFONTDESC DMACRO [X (COND
                                                   ((CDR X)
                                                    (CONS '\COERCEFONTDESC X))
                                                   (T `(\DTEST ,(CAR X)
                                                              'FONTDESCRIPTOR])
       (PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC)))

(PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO)
                                         (\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2)
                                                CSINFO)))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)

(PUTPROPS FONT FILETYPE :FAKE-COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FONTCOPY)
)
(PUTPROPS FONT COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1994 1999 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (8618 18137 (CHARWIDTH 8628 . 9413) (CHARWIDTHY 9415 . 10785) (STRINGWIDTH 10787 . 11880
) (\CHARWIDTH.DISPLAY 11882 . 12295) (\STRINGWIDTH.DISPLAY 12297 . 12721) (\STRINGWIDTH.GENERIC 12723
 . 18135)) (18138 24520 (DEFAULTFONT 18148 . 19981) (FONTCLASS 19983 . 22145) (FONTCLASSUNPARSE 22147
 . 23046) (FONTCLASSCOMPONENT 23048 . 23557) (SETFONTCLASSCOMPONENT 23559 . 24518)) (25194 37926 (
FONTCREATE 25204 . 34471) (\FONT.SYMBOLMEMB 34473 . 34703) (\FONT.SYMBOLASSOC 34705 . 35863) (
\FONT.COMPARESYMBOL 35865 . 37924)) (37965 42589 (FONTASCENT 37975 . 38143) (FONTDESCENT 38145 . 38414
) (FONTHEIGHT 38416 . 38602) (FONTPROP 38604 . 42047) (\AVGCHARWIDTH 42049 . 42587)) (42636 55275 (
GETCHARBITMAP 42646 . 45536) (PUTCHARBITMAP 45538 . 53595) (MOVECHARBITMAP 53597 . 55273)) (55276 
140202 (FONTCOPY 55286 . 60594) (FONTSAVAILABLE 60596 . 65801) (FONTFILEFORMAT 65803 . 67427) (FONTP 
67429 . 67728) (FONTUNPARSE 67730 . 70294) (SETFONTDESCRIPTOR 70296 . 72005) (CHARCODEP 72007 . 72368)
 (EDITCHAR 72370 . 72799) (\STREAMCHARWIDTH 72801 . 76965) (\UNITWIDTHSVECTOR 76967 . 77330) (
\CREATEDISPLAYFONT 77332 . 78085) (\CREATECHARSET.DISPLAY 78087 . 81003) (\CREATE-REAL-CHARSET.DISPLAY
 81005 . 88296) (\BUILDSLUGCSINFO 88298 . 89741) (\SEARCHDISPLAYFONTFILES 89743 . 91676) (
\SEARCHFONTFILES 91678 . 94989) (\FINDFONTFILE 94991 . 96182) (\FONTSYMBOL 96184 . 96834) (
\DEVICESYMBOL 96836 . 97705) (\FONTFACE 97707 . 104897) (\FONTFACE.COLOR 104899 . 111819) (
\FONTFILENAME 111821 . 115236) (\FONTFILENAME.OLD 115238 . 118187) (\FONTFILENAME.NEW 118189 . 120446)
 (\FONTINFOFROMFILENAME 120448 . 123562) (\FONTINFOFROMFILENAME.OLD 123564 . 125841) (\GETFONTDESC 
125843 . 126234) (\COERCEFONTDESC 126236 . 131621) (\LOOKUPFONT 131623 . 132967) (\LOOKUPFONTSINCORE 
132969 . 135042) (\READDISPLAYFONTFILE 135044 . 140200)) (141105 158155 (\READSTRIKEFONTFILE 141115 . 
145643) (\SFMAKEBOLD 145645 . 148041) (\SFMAKEITALIC 148043 . 150946) (\SFMAKEROTATEDFONT 150948 . 
152349) (\SFROTATECSINFO 152351 . 152988) (\SFROTATEFONTCHARACTERS 152990 . 153370) (
\SFFIXOFFSETSAFTERROTATION 153372 . 155511) (\SFROTATECSINFOOFFSETS 155513 . 156782) (\SFMAKECOLOR 
156784 . 158153)) (158156 166467 (WRITESTRIKEFONTFILE 158166 . 163007) (STRIKECSINFO 163009 . 166465))
 (181614 184470 (\CREATECHARSET 181624 . 184468)) (185556 187308 (\FONTRESETCHARWIDTHS 185566 . 187306
)))))
STOP
\ No newline at end of file
diff --git a/sources/FONT.LCOM b/sources/FONT.LCOM
index 317c274c..43f79cc2 100644
Binary files a/sources/FONT.LCOM and b/sources/FONT.LCOM differ
diff --git a/sources/FONT.LCOM.~6~ b/sources/FONT.LCOM.~6~
deleted file mode 100644
index 317c274c..00000000
Binary files a/sources/FONT.LCOM.~6~ and /dev/null differ
diff --git a/sources/FONT.~6~ b/sources/FONT.~6~
deleted file mode 100644
index b530eb3f..00000000
--- a/sources/FONT.~6~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "28-Jun-99 16:29:49" {DSK}<project>medley3.5>sources>FONT.;3 187933 

      changes to%:  (FNS \LOOKUPFONTSINCORE)

      previous date%: "28-Jun-99 16:22:27" {DSK}<project>medley3.5>sources>FONT.;2)


(* ; "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1999 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT FONTCOMS)

(RPAQQ FONTCOMS
       [
        (* ;; "font functions ")

        (FNS CHARWIDTH CHARWIDTHY STRINGWIDTH \CHARWIDTH.DISPLAY \STRINGWIDTH.DISPLAY 
             \STRINGWIDTH.GENERIC)
        (FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT)
        [COMS                                                (* ; 
                                                           "Until we pin down the exact interface")
              (P (MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT)
                 (MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT]
        [COMS                                                (* ; "MAPPING FOR DOS FILENAMES ")
              (INITVARS (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR)
                                                   (HELVETICA . HV)
                                                   (TIMESROMAND . TD)
                                                   (HELVETICAD . HD)
                                                   (MODERN . MD)
                                                   (CLASSIC . CL)
                                                   (GACHA . GC)
                                                   (TITAN . TI)
                                                   (LETTERGOTHIC . LG)
                                                   (BOLDPS . BP)
                                                   (TERMINAL . TM)
                                                   (CLASSICTHIN . CT)
                                                   (HIPPO . HP)
                                                   (LOGO . LG)
                                                   (MATH . MA)
                                                   (OLDENGLISH . OE)
                                                   (SYMBOL . SY]
        (COMS 
              (* ;; "Creation: ")

              (FNS FONTCREATE \FONT.SYMBOLMEMB \FONT.SYMBOLASSOC \FONT.COMPARESYMBOL))
        (COMS 
              (* ;; "Property extraction:")

              (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH))
        (COMS 
              (* ;; "Bitmap editing/manipulation:")

              (FNS GETCHARBITMAP PUTCHARBITMAP MOVECHARBITMAP))
        (FNS FONTCOPY FONTSAVAILABLE FONTFILEFORMAT FONTP FONTUNPARSE SETFONTDESCRIPTOR CHARCODEP 
             EDITCHAR \STREAMCHARWIDTH \UNITWIDTHSVECTOR \CREATEDISPLAYFONT \CREATECHARSET.DISPLAY 
             \CREATE-REAL-CHARSET.DISPLAY \BUILDSLUGCSINFO \SEARCHDISPLAYFONTFILES \SEARCHFONTFILES 
             \FINDFONTFILE \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR \FONTFILENAME 
             \FONTFILENAME.OLD \FONTFILENAME.NEW \FONTINFOFROMFILENAME \FONTINFOFROMFILENAME.OLD 
             \GETFONTDESC \COERCEFONTDESC \LOOKUPFONT \LOOKUPFONTSINCORE \READDISPLAYFONTFILE)
        (COMS 
              (* ;; "\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories.  That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places.  ")

              (ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE))
              (INITVARS (*USEOLDFONTDIRECTORIES* NIL))
              (GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)
              
              (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)")
)
        (COMS 
              (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)")

              (INITVARS (CACHEDISPLAYFONTS T))
              (GLOBALVARS CACHEDISPLAYFONTS)
                                                             (* ; "STRIKE format file support")
              (FNS \READSTRIKEFONTFILE \SFMAKEBOLD \SFMAKEITALIC \SFMAKEROTATEDFONT \SFROTATECSINFO 
                   \SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION \SFROTATECSINFOOFFSETS 
                   \SFMAKECOLOR)
              (FNS WRITESTRIKEFONTFILE STRIKECSINFO))
        (INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
        (SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
        (INITVARS (\FONTSINCORE)
               (\DEFAULTDEVICEFONTS)
               (\UNITWIDTHSVECTOR))
        (GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\UNITWIDTHSVECTOR)))
        (CONSTANTS (NORUNCODE 255))
        (EXPORT (OPTIMIZERS FONTPROP))
        [DECLARE%: DONTCOPY
               (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO)
                      (MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET \FGETWIDTH 
                             \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH \FGETIMAGEWIDTH \FSETIMAGEWIDTH
                             \GETCHARSETINFO \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR)
                      (FUNCTIONS \CREATEKERNELEMENT \FSETLEFTKERN \FGETLEFTKERN)
                      (CONSTANTS (\MAXNSCHAR 65535]
        (COMS                                                (* ; "NS Character specific code")
              (FNS \CREATECHARSET)
              (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS 
                     MISSINGCHARSETDISPLAYFONTCOERCIONS CHARSETERRORFLG)
              (INITVARS (DISPLAYFONTCOERCIONS NIL)
                     [MISSINGCHARSETDISPLAYFONTCOERCIONS '(((GACHA)
                                                            (TERMINAL))
                                                           ((MODERN)
                                                            (CLASSIC))
                                                           ((TIMESROMAN)
                                                            (CLASSIC))
                                                           ((HELVETICA)
                                                            (MODERN))
                                                           ((TERMINAL 6)
                                                            (MODERN 6))
                                                           ((TERMINAL 8)
                                                            (MODERN 8))
                                                           ((TERMINAL 10)
                                                            (MODERN 10))
                                                           ((TERMINAL 12)
                                                            (MODERN 12]
                     [MISSINGDISPLAYFONTCOERCIONS '(((GACHA)
                                                     (TERMINAL))
                                                    ((MODERN)
                                                     (CLASSIC))
                                                    ((TIMESROMAN)
                                                     (CLASSIC))
                                                    ((HELVETICA)
                                                     (MODERN]
                     (CHARSETERRORFLG NIL)
                     (\DEFAULTCHARSET 0)))
        (FNS \FONTRESETCHARWIDTHS)
        [DECLARE%: DONTEVAL@LOAD (INITVARS (DISPLAYFONTEXTENSIONS 'DISPLAYFONT)
                                        (DISPLAYFONTDIRECTORIES '(
                                                      {DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/
                                                                  
                                                        {dsk}/usr/local/lde/fonts/display/publishing/
                                                                  ]
        (MACROS \FGETCHARIMAGEWIDTH \GETFONTDESC \SETCHARSETINFO)
        (LOCALVARS . T)
        (PROP FILETYPE FONT)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA FONTCOPY])



(* ;; "font functions ")

(DEFINEQ

(CHARWIDTH
  [LAMBDA (CHARCODE FONT)                                (* rmk%: "12-Apr-85 09:46")
                                                             (* ; 
                                              "gets the width of a character code in a font/stream")
    (OR (\CHARCODEP CHARCODE)
        (\ILLEGAL.ARG CHARCODE))
    (LET (TEMP)
         (COND
            ((type? FONTDESCRIPTOR FONT)
             (\FGETCHARWIDTH FONT CHARCODE))
            ((SETQ TEMP (\OUTSTREAMARG FONT T))              (* ; 
                                                     "NIL font goes thru here--primary output file")
             (IMAGEOP 'IMCHARWIDTH TEMP TEMP CHARCODE))
            (T (\FGETCHARWIDTH (FONTCREATE FONT)
                      CHARCODE])

(CHARWIDTHY
  [LAMBDA (CHARCODE FONT)                                (* edited%: "18-Mar-86 19:30")
                                                             (* ; 
                                 "Gets the Y-component of the width of a character code in a font.")
    (OR (\CHARCODEP CHARCODE)
        (\ILLEGAL.ARG CHARCODE))
    (LET (TEMP WY)
         (COND
            ((type? FONTDESCRIPTOR FONT)
             (SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                      FONT)))
             (COND
                ((FIXP WY))
                (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
                (T 0)))
            ((type? STREAM (SETQ TEMP (\OUTSTREAMARG FONT T)))
                                                             (* ; 
                                                     "NIL font goes thru here--primary output file")
             (IMAGEOP 'IMCHARWIDTHY TEMP TEMP CHARCODE))
            (T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                        (FONTCREATE FONT]
               (COND
                  ((FIXP WY))
                  (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
                  (T 0])

(STRINGWIDTH
  [LAMBDA (STR FONT FLG RDTBL)                           (* ; "Edited  8-Jan-88 14:41 by Snow")

    (* ;; "Returns the width of STR according to FONT")

    (LET (TEMP)

         (* ;; "Used in \MAPCHARS")

         (COND
            [(type? FONTDESCRIPTOR FONT)
             (\STRINGWIDTH.GENERIC STR FONT (AND FLG (\GTREADTABLE RDTBL))
                    (\FGETCHARWIDTH FONT (CHARCODE SPACE]
            [(AND FONT (SETQ TEMP (\OUTSTREAMARG FONT T)))   (* ; 
  "if you gave something for FONT, coerce it to a stream, and call the stringwidth function of it.")
             (IMAGEOP 'IMSTRINGWIDTH TEMP TEMP STR (AND FLG (\GTREADTABLE RDTBL]
            (T (SETQ TEMP (FONTCREATE (OR FONT DEFAULTFONT)))
                                                             (* ; "NIL font will pass thru here.  ie, defaultfont is used to do the stringwidth instead of the font of *standard-output*")
               (\STRINGWIDTH.GENERIC STR TEMP (AND FLG (\GTREADTABLE RDTBL))
                      (\FGETCHARWIDTH TEMP (CHARCODE SPACE])

(\CHARWIDTH.DISPLAY
  [LAMBDA (STREAM CHARCODE)                              (* rmk%: "12-Apr-85 09:42")
                                                             (* ; 
         "gets the width of a character code in a display stream.  Need to fix up for spacefactor.")
    (\FGETCHARWIDTH (ffetch (\DISPLAYDATA DDFONT) of (ffetch IMAGEDATA of STREAM))
           CHARCODE])

(\STRINGWIDTH.DISPLAY
  [LAMBDA (STREAM STR RDTBL)                             (* ; "Edited  3-Apr-87 12:07 by jop")

    (* ;; "Returns the width of for the current font/spacefactor in STREAM.")

    (LET ((DD (ffetch IMAGEDATA of STREAM)))
         (\STRINGWIDTH.GENERIC STR (ffetch (\DISPLAYDATA DDFONT) of DD)
                RDTBL
                (ffetch DDSPACEWIDTH of DD])

(\STRINGWIDTH.GENERIC
  [LAMBDA (STR FONT RDTBL SPACEWIDTH)                    (* ; "Edited  3-Apr-87 13:47 by jop")

    (* ;; "Returns the width of STR with SPACEWIDTH for the width of spaces.  RDTBL has already been coerced, so no FLG is needed ")

    (* ;; "This is cloned in \STRINGWIDTH.HCPYDISPLAYAUX by straight substitution -- (PUTDEF (QUOTE \STRINGWIDTH.HCPYDISPLAYAUX) (QUOTE FNS) (SUBLIS (QUOTE ((WIDTHS  . IMAGEWIDTHS) (\FGETWIDTH  . \FGETIMAGEWIDTH) (\FGETCHARWIDTH  . \FGETCHARIMAGEWIDTH))) (GETDEF (QUOTE \STRINGWIDTH.GENERIC))))")

    (* ;; "\MAPPNAME uses WIDTHSBASE CSET TOTALWIDTH FONT SPACEWIDTH free, so these become special in bytecompiler")

    (PROG NIL
          [COND
             [(LITATOM STR)
              (if RDTBL
                  then (GO SLOW)
                else (RETURN (for C WIDTHSBASE CSET inatom STR
                                    sum [COND
                                               ((NEQ CSET (\CHARSET C))
                                                (SETQ CSET (\CHARSET C))
                                                (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
                                                                    of (\GETCHARSETINFO CSET FONT
                                                                                  ]
                                          (COND
                                             ((EQ C (CHARCODE SPACE))
                                              SPACEWIDTH)
                                             (T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C]
             ((STRINGP STR)
              (RETURN
               (LET ((TOTAL 0)
                     ESC ESCWIDTH WIDTHSBASE CSET)
                    [COND
                       (RDTBL                                (* ; 
                                                     "Count delimiting quotes and internal escapes")
                              (SETQ TOTAL (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %"))
                                                 2))
                              (SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL))
                              (SETQ ESCWIDTH (\FGETCHARWIDTH FONT ESC]
                    [for C instring STR
                       do [COND
                                 ((NEQ (\CHARSET C)
                                       CSET)                 (* ; 
                                                     "Get the widths vector for this character set")
                                  (SETQ CSET (\CHARSET C))
                                  (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
                                                      of (\GETCHARSETINFO CSET FONT]
                             (add TOTAL (COND
                                               ((EQ C (CHARCODE SPACE))
                                                SPACEWIDTH)
                                               (T (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C))
                                                         (COND
                                                            ((AND RDTBL (OR (EQ C (CHARCODE %"))
                                                                            (EQ C ESC)))
                                                             (* ; "String char must be escaped")
                                                             ESCWIDTH)
                                                            (T 0]
                    TOTAL]
      SLOW
                                                             (* ; "Do the general case here")
          (RETURN (LET ((TOTALWIDTH 0)
                        WIDTHSBASE CSET (FONT FONT)
                        (SPACEWIDTH SPACEWIDTH))
                       (DECLARE (SPECVARS TOTALWIDTH WIDTHSBASE CSET FONT SPACEWIDTH))
                       (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CC)
                                              (add TOTALWIDTH (COND
                                                                     ((EQ CC (CHARCODE SPACE))
                                                                      SPACEWIDTH)
                                                                     ((EQ CSET (\CHARSET CC))
                                                                      (\FGETWIDTH WIDTHSBASE
                                                                             (\CHAR8CODE CC)))
                                                                     (T (SETQ CSET (\CHARSET CC))
                                                                        (SETQ WIDTHSBASE
                                                                         (ffetch (CHARSETINFO
                                                                                      WIDTHS)
                                                                            of (\GETCHARSETINFO
                                                                                    CSET FONT)))
                                                                        (\FGETWIDTH WIDTHSBASE
                                                                               (\CHAR8CODE CC]
                              STR RDTBL RDTBL *PRINT-LEVEL* *PRINT-LENGTH*)
                       TOTALWIDTH])
)
(DEFINEQ

(DEFAULTFONT
  [LAMBDA (DEVICE FONT NOERRORFLG)                       (* ; "Edited 28-Jul-88 13:15 by rmk:")
                                                             (* ; "Edited 24-Mar-87 14:41 by FS")

    (* ;; "Returns the default font for an image type.  Really only needed to guarantee validity of the display default font for system critical routines, in case the user has smashed the variable DEFAULTFONT.  Note that SETFONTCLASSCOMPONENT and FONTCLASS guarantee that the display component is either NIL or a fontdescriptor.")

    (* ;; "FS- If FONT provided set the font descriptor.  Do not bother to check if NOERRORFLG is NEW. (old code had (AND FONT (EQ NOERRORFLG 'NEW)))")

    [OR (type? FONTCLASS DEFAULTFONT)
        (SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT]
    (if FONT
        then 

              (* ;; "FS- Not clear the fontclass should be smashed, perhaps instead should make a new FONTCLASS and then rebind DEFAULTFONT.  Leaving alone for histerical reasons")

              (SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE FONT)
      else 

            (* ;; "The code below (not mine!) is messy but is correct (unless weirdness pops up because of deep recursion).")

            (COND
               ((\COERCEFONTDESC DEFAULTFONT DEVICE T))
               (NOERRORFLG NIL)
               ((EQ (\DEVICESYMBOL DEVICE T)
                    'DISPLAY)

                (* ;; "If getting for the display and the font can't be found perhaps because of garbage in the display field of the DEFAULTFONTCLASS, then the system-guaranteed displayfont.  Otherwise, cause the error in the re-coercion.  Can never tell when DEVICE is just a symbol.")

                \GUARANTEEDDISPLAYFONT)
               ((\COERCEFONTDESC DEFAULTFONT DEVICE])

(FONTCLASS
  [LAMBDA (NAME FONTLIST CREATEFORDEVICES)               (* jds " 9-Sep-86 18:49")

    (* ;; "This builds D style font classes, which are datatypes containing entries for the various known devices.")

    (* ;; "Don't actually set up the for devices not inside CREATEFORDEVICES on the theory that any given user presumably doesn't want all the fonts for all the devices.  We wait until he actually asks for the font or the fontmaparray, at which point we note that the fields don't contain FD's, so we then apply FONTCREATE.  The actual coercion and caching is done inside \COERCEFONTDESC.  However, so as to prevent display crashes, if a display component is specified, we always do the fontcreate before we stick it in.")

    (PROG (F FC FL)
          (SETQ FL FONTLIST)
          [SETQ FC (create FONTCLASS
                          FONTCLASSNAME _ NAME
                          PRETTYFONT# _ (OR (FIXP (pop FL))
                                            1)
                          DISPLAYFD _ (AND (SETQ F (pop FL))
                                           (FONTCREATE F NIL NIL NIL 'DISPLAY))
                          PRESSFD _ (pop FL)
                          INTERPRESSFD _ (pop FL)
                          OTHERFDS _ (for FSPEC in FL
                                        collect (OR (AND (LISTP FSPEC)
                                                             (ATOM (CAR FSPEC))
                                                             (CAR FSPEC))
                                                        (ERROR "illegal font class specification"
                                                               (LIST NAME FONTLIST))) 
                                                             (* ; 
                                     "Copy the alist entry so it can be smashed in \COERCEFONTDESC")
                                              (CONS (CAR FSPEC)
                                                    (CAR (LISTP (CDR FSPEC]
          (for D inside CREATEFORDEVICES do (FONTCREATE FC NIL NIL NIL D))
          (RETURN FC])

(FONTCLASSUNPARSE
  [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG)         (* jds "24-Jan-86 11:58")
                                                             (* ; 
                                "Given a font class, unparse it to a form that might be reparsable")
    (APPEND (LIST (fetch (FONTCLASS FONTCLASSNAME) of FONTCLASS)
                  (fetch (FONTCLASS PRETTYFONT#) of FONTCLASS)
                  (FONTUNPARSE (ffetch (FONTCLASS DISPLAYFD) of FONTCLASS))
                  (FONTUNPARSE (ffetch (FONTCLASS PRESSFD) of FONTCLASS))
                  (FONTUNPARSE (ffetch (FONTCLASS INTERPRESSFD) of FONTCLASS)))
           (for X in (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
              collect (LIST (CAR X)
                                (FONTUNPARSE (CDR X])

(FONTCLASSCOMPONENT
  [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG)         (* rmk%: "14-Sep-84 19:34")
    (PROG1 (FONTCREATE FONTCLASS NIL NIL NIL DEVICE NOERRORFLG)
                                                             (* ; 
                    "This works its way down to \COERCEFONTDESC, where it needs to be done quickly")
        (AND FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL DEVICE NOERRORFLG))
             (SETFONTCLASSCOMPONENT FONTCLASS DEVICE FONT)))])

(SETFONTCLASSCOMPONENT
  [LAMBDA (FONTCLASS DEVICE FONT)                    (* ; "Edited 29-Aug-91 12:20 by jds")
    (PROG ((NEWFONT (FONTCREATE FONT NIL NIL NIL DEVICE)))

     (* ;; "replaces will barf if FONTCLASS is not a fontclass")

          (SELECTQ (SETQ DEVICE (FONTPROP NEWFONT 'DEVICE))
              (DISPLAY (replace (FONTCLASS DISPLAYFD) of FONTCLASS with NEWFONT))
              (INTERPRESS (replace (FONTCLASS INTERPRESSFD) of FONTCLASS with NEWFONT
                                 ))
              (PRESS (replace (FONTCLASS PRESSFD) of FONTCLASS with NEWFONT))
              (RPLACD [OR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of FONTCLASS))
                          (CAR (push (fetch (FONTCLASS OTHERFDS) of FONTCLASS)
                                      (CONS DEVICE]
                     NEWFONT))
          (RETURN NEWFONT])
)



(* ; "Until we pin down the exact interface")


(MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT)

(MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT)



(* ; "MAPPING FOR DOS FILENAMES ")


(RPAQ? *DISPLAY-FONT-NAME-MAP*
       '((TIMESROMAN . TR)
         (HELVETICA . HV)
         (TIMESROMAND . TD)
         (HELVETICAD . HD)
         (MODERN . MD)
         (CLASSIC . CL)
         (GACHA . GC)
         (TITAN . TI)
         (LETTERGOTHIC . LG)
         (BOLDPS . BP)
         (TERMINAL . TM)
         (CLASSICTHIN . CT)
         (HIPPO . HP)
         (LOGO . LG)
         (MATH . MA)
         (OLDENGLISH . OE)
         (SYMBOL . SY)))



(* ;; "Creation: ")

(DEFINEQ

(FONTCREATE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)
                                                             (* ; "Edited 10-Oct-88 09:53 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:43 by rmk:")
                                                             (* ; "Edited 10-Nov-87 18:08 by FS")

    (* ;; "Create a font descriptor for the specified font.  If NOERRORFLG, return NIL if the font doesn't exist;  otherwise cause an error.")

    (* ;; "Cache and fonts.widths traffic in uppercase only.")

    (* ;; "character set is optional and defaults to \DEFAULTCHARSET (0 in our world)")

    (DECLARE (GLOBALVARS IMAGESTREAMTYPES \DEFAULTCHARSET))
    (PROG (FONTX (CHSET (OR CHARSET \DEFAULTCHARSET)))
          (RETURN (COND
                     ((LISTP FAMILY)
                      (SELECTQ (CAR FAMILY)
                          (FONT (SETQ FONTX (CDR FAMILY)))
                          (CLASS (COND
                                    ((LITATOM (CADR FAMILY)) (* ; "litatom class name")
                                     (RETURN (FONTCLASS (CADR FAMILY)
                                                    (CDDR FAMILY)
                                                    DEVICE)))
                                    (T                       (* ; 
                     "Allows for a font named CLASS--distinguished cause its size is not a litatom")
                                       (SETQ FONTX FAMILY))))
                          (SETQ FONTX FAMILY))
                      (FONTCREATE (CAR FONTX)
                             (OR (CADR FONTX)
                                 SIZE)
                             (OR (CADDR FONTX)
                                 FACE)
                             (OR (CADDDR FONTX)
                                 ROTATION)
                             (OR (CADR (CDDDR FONTX))
                                 DEVICE)
                             NOERRORFLG CHSET))
                     ([SETQ FONTX (COND
                                     ((type? FONTDESCRIPTOR FAMILY)
                                      FAMILY)
                                     ((NULL FAMILY)
                                      (DEFAULTFONT DEVICE))
                                     ((type? FONTCLASS FAMILY)

                                 (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.  Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.")

                                      (\COERCEFONTDESC FAMILY DEVICE NOERRORFLG))
                                     ((OR (IMAGESTREAMP FAMILY)
                                          (type? WINDOW FAMILY))
                                      (DSPFONT NIL FAMILY]

                      (* ;; 
                 "FAMILY was a spec for a font descriptor, use it and extend it by the other args.")

                      (COND
                         ((OR SIZE FACE ROTATION DEVICE)
                          (FONTCREATE (FONTPROP FONTX 'FAMILY)
                                 (OR SIZE (FONTPROP FONTX 'SIZE))
                                 (OR FACE (FONTPROP FONTX 'FACE))
                                 (OR ROTATION (FONTPROP FONTX 'ROTATION))
                                 (OR DEVICE (FONTPROP FONTX 'DEVICE))
                                 NOERRORFLG))
                         (T FONTX)))
                     (T (PROG (FONTFACE (DEV DEVICE))
                          RETRY
                              [OR (LITATOM FAMILY)
                                  (COND
                                     (NOERRORFLG (RETURN))
                                     (T (LISPERROR "ARG NOT LITATOM" FAMILY T]
                              [OR (AND (FIXP SIZE)
                                       (IGREATERP SIZE 0))
                                  (COND
                                     (NOERRORFLG (RETURN NIL))
                                     (T (\ILLEGAL.ARG SIZE]
                              (COND
                                 ((NULL ROTATION)
                                  (SETQ ROTATION 0))
                                 ((AND (FIXP ROTATION)
                                       (IGEQ ROTATION 0)))
                                 (NOERRORFLG (RETURN NIL))
                                 (T (\ILLEGAL.ARG ROTATION)))
                              [SETQ DEV (COND
                                           ((NULL DEVICE)
                                            'DISPLAY)
                                           ((AND (LITATOM DEVICE)
                                                 (NEQ DEVICE T))
                                                             (* ; 
"Maybe wrong case or package, but we bet it's OK and defer  expensive coercion until we've failed.")
                                            DEV)
                                           ((SETQ DEV (\GETSTREAM DEVICE 'OUTPUT T))
                                                             (* ; 
                                                           "T coerces here to primary output")
                                            (fetch (IMAGEOPS IMFONTCREATE)
                                               of (fetch (STREAM IMAGEOPS) of DEV)))
                                           ((STRINGP DEVICE)
                                            (MKATOM (U-CASE DEVICE)))
                                           (NOERRORFLG (RETURN NIL))
                                           (T (\ILLEGAL.ARG DEVICE]
                                                             (* ; "DEV is now guanteed litatom")
                          NEWDEV
                                                             (* ; 
                                                  "Check after device since it is device-dependent")
                              (SETQ FONTFACE (OR (\FONTFACE FACE NOERRORFLG DEV)
                                                 (RETURN NIL)))
                                                             (* ; "Don't truly coerce to \FONTSYMBOL or \DEVICESYMBOL until we've had a shot at the font cache, since re-interning atoms is so expensive")
                              [RETURN (COND
                                         ((\LOOKUPFONT FAMILY SIZE FONTFACE ROTATION DEV))
                                         [(SETQ FONTX (CDR (ASSOC DEV IMAGESTREAMTYPES)))

                                 (* ;; "Device is valid, font just doesn't exist.   FONTFACE, DEV already canonical.  Make FAMILY so, so that each imagestream type doesn't have to.")

                                          (SETQ FAMILY (\FONTSYMBOL FAMILY))
                                          (COND
                                             ((SETQ FONTX (APPLY* (OR (CADR (ASSOC 'FONTCREATE FONTX)
                                                                            )
                                                                      (FUNCTION NILL))
                                                                 FAMILY SIZE FONTFACE ROTATION DEV 
                                                                 CHSET))

                                      (* ;; "default creation case.  Use fontcreate method from device, build a fontdescriptor and use setfontdescriptor to install it.")

                                 (* ;; "OBSOLETEd by the CHARSETINFO code (OR (ffetch FONTIMAGEWIDTHS of FONTX) (freplace FONTIMAGEWIDTHS of FONTX with (ffetch \SFWidths of FONTX)))")

                                              (* ;; 
             "the widths fields in the fontdescriptor are obsolete, and shoudln't be updated here.")

                                           (* ;; "We should probably force all device implementations to obey these conventions, then remove these generic updates")

                                              (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH)
                                                 of FONTX with (\AVGCHARWIDTH FONTX))
                                              (SETFONTDESCRIPTOR FAMILY SIZE FONTFACE ROTATION 
                                                     DEV FONTX))
                                             (T (GO NOTFOUND]
                                         ((NEQ DEV (SETQ DEV (U-CASE DEV)))

                                 (* ;; "We didn't recognize the device, so check to see whether coercion to U-CASE IL changes anything.  Could be slow, but we're heading for an error.")

                                          (GO NEWDEV))
                                         (T (GO NOTFOUND]
                          NOTFOUND
                              (COND
                                 (NOERRORFLG (RETURN NIL))
                                 (T (ERROR "FONT NOT FOUND (coerced to)"
                                           (LIST FAMILY SIZE FONTFACE ROTATION DEV))
                                    (GO RETRY])

(\FONT.SYMBOLMEMB
  [LAMBDA (USERINPUT LIST)                               (* ; "Edited  7-Feb-89 15:47 by jds")
    (for X on LIST when (\FONT.COMPARESYMBOL USERINPUT (CAR X))
       do (RETURN X])

(\FONT.SYMBOLASSOC
  [LAMBDA (USERINPUT LIST)                               (* ; "Edited 28-Jul-88 16:56 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:15 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:03 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:16 by rmk:")
    (for X FIRSTC (NC _ (NCHARS USERINPUT)) in LIST
       first (SETQ FIRSTC (CHCON1 USERINPUT))
             [if (AND (IGEQ FIRSTC (CHARCODE a))
                          (ILEQ FIRSTC (CHARCODE z)))
                 then (SETQ FIRSTC (IDIFFERENCE FIRSTC (IDIFFERENCE (CHARCODE a)
                                                                  (CHARCODE A]
       when (AND (EQ NC (NCHARS (CAR X)))
                     (EQ FIRSTC (CHCON1 (CAR X)))
                     (\FONT.COMPARESYMBOL USERINPUT (CAR X)
                            NC FIRSTC)) do (RETURN X])

(\FONT.COMPARESYMBOL
  [LAMBDA (USERINPUT KEY INPUTNC INPUTFIRSTC) (* ; 
                                                "Edited 24-May-93 16:45 by sybalsky:mv:envos")

    (* ;; " An open coded case- and package-insensitive comparison of atom pnames, assuming that KEY is already upper-case but USERINPUT may not be.  Maybe there is a simple function that does this.")

    (* ;; "INPUTNC and INPUTFIRSTC can be passed in if they are common to lots of calls")

    (COND
       ((AND (LITATOM USERINPUT)
             (EQ [CL:AREF *PACKAGE-FROM-INDEX* (fetch (PNAMECELL PACKAGEINDEX)
                                                  of (PROGN (\PNAMECELL USERINPUT]
                 *INTERLISP-PACKAGE*))

        (* ;; "If the user's symbol is in the IL package (which is where all the KEYs are), we can use EQ, which is MUCH faster.")

        (OR (EQ USERINPUT KEY)
            (EQ (U-CASE USERINPUT)
                KEY)))
       (T 
          (* ;; "Otherwise, we do the comparison character by character.")

          (AND (EQ (OR INPUTNC (NCHARS USERINPUT))
                   (NCHARS KEY))
               [COND
                  (INPUTFIRSTC (EQ INPUTFIRSTC (CHCON1 KEY)))
                  ((EQ (SETQ INPUTFIRSTC (CHCON1 USERINPUT))
                       (CHCON1 KEY)))
                  ((AND (IGEQ INPUTFIRSTC (CHARCODE a))
                        (ILEQ INPUTFIRSTC (CHARCODE z)))
                   (EQ (IDIFFERENCE INPUTFIRSTC (IDIFFERENCE (CHARCODE a)
                                                       (CHARCODE A)))
                       (CHCON1 KEY]
               (for CHAR1 inatom USERINPUT as CHAR2 inatom KEY
                  always (OR (EQ CHAR1 CHAR2)
                                 (AND (IGEQ CHAR1 (CHARCODE a))
                                      (ILEQ CHAR1 (CHARCODE z))
                                      (EQ CHAR2 (IPLUS CHAR1 (CONSTANT (IDIFFERENCE (CHARCODE A)
                                                                              (CHARCODE a])
)



(* ;; "Property extraction:")

(DEFINEQ

(FONTASCENT
  [LAMBDA (FONTSPEC)                                     (* lmm "19-NOV-82 00:23")
    (ffetch \SFAscent of (\GETFONTDESC FONTSPEC])

(FONTDESCENT
  [LAMBDA (FONTSPEC)                                     (* lmm "19-NOV-82 00:24")
                                                             (* ; "See comment in FONTASCENT")
    (ffetch \SFDescent of (\GETFONTDESC FONTSPEC])

(FONTHEIGHT
  [LAMBDA (FONTSPEC)                                     (* kbr%: " 9-Jan-86 18:29")
    (fetch (FONTDESCRIPTOR \SFHeight) of (\GETFONTDESC FONTSPEC])

(FONTPROP
  [LAMBDA (FONT PROP)                                    (* kbr%: "13-May-85 22:36")
    (SETQ FONT (\GETFONTDESC FONT))
    (SELECTQ PROP
        (HEIGHT (ffetch \SFHeight of FONT))
        (ASCENT (ffetch \SFAscent of FONT))
        (DESCENT (ffetch \SFDescent of FONT))
        (FAMILY (ffetch FONTFAMILY of FONT))
        (SIZE (ffetch FONTSIZE of FONT))
        (FACE (COPY (ffetch FONTFACE of FONT)))
        (WEIGHT (ffetch WEIGHT of (ffetch FONTFACE of FONT)))
        (SLOPE (ffetch SLOPE of (ffetch FONTFACE of FONT)))
        (EXPANSION (ffetch EXPANSION of (ffetch FONTFACE of FONT)))
        (FORECOLOR (ffetch FORECOLOR of (ffetch FONTFACE of FONT)))
        (BACKCOLOR (ffetch BACKCOLOR of (ffetch FONTFACE of FONT)))
        (ROTATION (ffetch ROTATION of FONT))
        (DEVICE (ffetch FONTDEVICE of FONT))
        (SPEC (LIST (ffetch FONTFAMILY of FONT)
                    (ffetch FONTSIZE of FONT)
                    (COPY (ffetch FONTFACE of FONT))
                    (ffetch ROTATION of FONT)
                    (ffetch FONTDEVICE of FONT)))
        (DEVICESPEC                                          (* ; 
                  "DEVICE fields are for communicating coercions to the particular printing device")
                    [COND
                       ((ffetch FONTDEVICESPEC of FONT)
                        (COPY (ffetch FONTDEVICESPEC of FONT)))
                       (T (FONTPROP FONT 'SPEC])
        (DEVICEFACE [COPY (COND
                             ((ffetch FONTDEVICESPEC of FONT)
                              (CADDR (ffetch FONTDEVICESPEC of FONT)))
                             (T (ffetch FONTFACE of FONT])
        (DEVICESLOPE [fetch SLOPE of (COND
                                                ((ffetch FONTDEVICESPEC of FONT)
                                                 (CADDR (ffetch FONTDEVICESPEC of FONT)))
                                                (T (ffetch FONTFACE of FONT])
        (DEVICEWEIGHT [fetch WEIGHT of (COND
                                                  ((ffetch FONTDEVICESPEC of FONT)
                                                   (CADDR (ffetch FONTDEVICESPEC of FONT)))
                                                  (T (ffetch FONTFACE of FONT])
        (DEVICEEXPANSION 
             [fetch EXPANSION of (COND
                                            ((ffetch FONTDEVICESPEC of FONT)
                                             (CADDR (ffetch FONTDEVICESPEC of FONT)))
                                            (T (ffetch FONTFACE of FONT])
        (DEVICESIZE (COND
                       ((ffetch FONTDEVICESPEC of FONT)
                        (CADR (ffetch FONTDEVICESPEC of FONT)))
                       (T (ffetch FONTSIZE of FONT))))
        (DEVICEFAMILY (COND
                         ((ffetch FONTDEVICESPEC of FONT)
                          (CAR (ffetch FONTDEVICESPEC of FONT)))
                         (T (ffetch FONTFAMILY of FONT))))
        (SCALE (ffetch FONTSCALE of FONT))
        (\ILLEGAL.ARG PROP])

(\AVGCHARWIDTH
  [LAMBDA (FONT)                                         (* rmk%: "27-Nov-84 18:40")

    (* ;; "Returns the average width of a character, to be used in units-to-characters approximations, as in fixing the linelength")

    (PROG ((W (CHARWIDTH (CHARCODE A)
                     FONT)))
          (RETURN (COND
                     ((NEQ 0 W)
                      W)
                     ([NEQ 0 (SETQ W (FIXR (FTIMES 0.6 (FONTPROP FONT 'HEIGHT]
                      W)
                     (T 1])
)



(* ;; "Bitmap editing/manipulation:")

(DEFINEQ

(GETCHARBITMAP
  [LAMBDA (CHARCODE FONT)                                (* ; "Edited 26-Apr-89 21:49 by atm")
                                                             (* ; 
                    "returns a bitmap of the character CHARCODE from the font descriptor FONTDESC.")
    (COND
       ((OR (CHARCODEP CHARCODE)
            (EQ CHARCODE 256))                               (* ; 
                                       "bitmap for char 256 is what gets printed if char not found")
        )
       ((OR (STRINGP CHARCODE)
            (LITATOM CHARCODE))                              (* ; 
                                                 "For strings & litatoms, take the first character")
        (SETQ CHARCODE (CHCON1 CHARCODE)))
       ((TYPEP CHARCODE 'CL:CHARACTER)                       (* ; 
                                   "For common-lisp CHARACTERs, convert it to the char code first.")
        (SETQ CHARCODE (CL:CHAR-INT CHARCODE)))
       (T (\ILLEGAL.ARG CHARCODE)))
    (PROG (CBM (FONTDESC (\GETFONTDESC FONT))
               CSINFO CWDTH CHGHT)

     (* ;; "fetch the csinfo for the character set of this character.  Bitmaps and widths must be fetched from it")

          (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
                              FONTDESC))

     (* ;; "(\\fgetwidth (|fetch| (charsetinfo widths) |of| csinfo) (\\char8code charcode))")

          [SETQ CBM (BITMAPCREATE [SETQ CWDTH (if (fetch (CHARSETINFO IMAGEWIDTHS)
                                                         of CSINFO)
                                                  then (\FGETIMAGEWIDTH (fetch (CHARSETINFO
                                                                                        IMAGEWIDTHS)
                                                                               of CSINFO)
                                                                  (\CHAR8CODE CHARCODE))
                                                else (\FGETWIDTH (fetch (CHARSETINFO WIDTHS)
                                                                        of CSINFO)
                                                                (\CHAR8CODE CHARCODE]
                           (SETQ CHGHT (FONTPROP FONTDESC 'HEIGHT))
                           (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CHARSETINFO
                                                                                     CHARSETBITMAP)
                                                                            of CSINFO]
          (BITBLT (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
                 (\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO)
                        (\CHAR8CODE CHARCODE))
                 0 CBM 0 0 CWDTH CHGHT)
          (RETURN CBM])

(PUTCHARBITMAP
  [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT)   (* ; "Edited 27-Apr-89 11:19 by atm")

    (* ;; "stores the bitmap NEWCHARBITMAP as the character CHARCODE from the font descriptor FONTDESC.  If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.")

    (OR (TYPENAMEP NEWCHARBITMAP 'BITMAP)
        (\ILLEGAL.ARG NEWCHARBITMAP))
    (COND
       ((CHARCODEP CHARCODE))
       ((OR (STRINGP CHARCODE)
            (LITATOM CHARCODE))
        (SETQ CHARCODE (CHCON1 CHARCODE)))
       (T (\ILLEGAL.ARG CHARCODE)))
    (PROG* ((FONTDESC (\GETFONTDESC FONT))
            (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
                           FONTDESC))
            (CDESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
            (CASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
            (CHEIGHT (IPLUS CDESCENT CASCENT))
            (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
            (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
            (IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))
            (CIMWIDTH (if IMWIDTHS
                          then (\FGETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE))
                        else NIL))
            (CWIDTH (OR CIMWIDTH (CHARWIDTH CHARCODE FONTDESC)))
            (FONTBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
            (OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP))
            TEMPBITMAP BWIDTH DW BHEIGHT BASCENT BDESCENT NDESCENT NASCENT NHEIGHT CHAROFFSET
            (BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of FONTBITMAP)))

     (* ;; "fetch the ascents and descents of the bitmap and the new maximums.")

           (SETQ BWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP))
           (SETQ BHEIGHT (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP))
           (SETQ BDESCENT (OR NEWCHARDESCENT CDESCENT))
           (SETQ BASCENT (IDIFFERENCE BHEIGHT BDESCENT))
           (SETQ NDESCENT (IMAX BDESCENT CDESCENT))
           (SETQ NASCENT (IMAX BASCENT CASCENT))
           (SETQ NHEIGHT (IPLUS NDESCENT NASCENT))
           (SETQ CHAROFFSET (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE)))

     (* ;; "set up a new target bitmap if any of the parameters have changed.")

           (COND
              ((EQ CHAROFFSET (\FGETOFFSET OFFSETS \MAXTHINCHAR))

               (* ;; "changing the bitmap for a character which formerly pointed at the slug character.  Allocate a new bitmap character bitmap for this.")

               (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH BWIDTH)
                                       NHEIGHT BITSPERPIXEL))
               (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      OFWIDTH CHEIGHT)                       (* ; "copy the old characters over.")
               (SETQ CHAROFFSET OFWIDTH))
              ((NEQ CWIDTH BWIDTH)

               (* ;; "The bitmaps differ in width;  create a new bitmap with things at the right places, then update widths and offsets.")

               (SETQ DW (IDIFFERENCE BWIDTH CWIDTH))         (* ; "Difference in character widths")
               (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW)
                                       NHEIGHT BITSPERPIXEL))(* ; 
                              "this may also be a taller bitmap if NHEIGHT is larger than CHEIGHT.")
               (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      CHAROFFSET CHEIGHT)                    (* ; 
                                                  "Copy that portion to the left of the character.")
               (BITBLT FONTBITMAP (IPLUS CHAROFFSET CWIDTH)
                      0 TEMPBITMAP (IPLUS CHAROFFSET BWIDTH)
                      (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      (ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWIDTH)))
                      CHEIGHT)                               (* ; 
                                             "Copy that portion to the right of the new character.")
               )
              ((OR (IGREATERP BASCENT CASCENT)
                   (IGREATERP BDESCENT CDESCENT))

               (* ;; "The new character is TALLER than the existing bitmap.  Make a larger bitmap.")

               (SETQ TEMPBITMAP (BITMAPCREATE OFWIDTH NHEIGHT BITSPERPIXEL))
               (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                      OFWIDTH CHEIGHT)

               (* ;; "Copy the existing bitmap into it, adjusting for a larger descent in the new character (if there is one)")

               ))

     (* ;; "copy the new bitmap in and update parameters.")

           (BITBLT NEWCHARBITMAP 0 0 (OR TEMPBITMAP FONTBITMAP)
                  CHAROFFSET
                  (IMAX 0 (IDIFFERENCE NDESCENT BDESCENT))
                  BWIDTH BHEIGHT)
           [COND
              (TEMPBITMAP (UNINTERRUPTABLY
                              
                              (* ;; "update the parameters for this character set.")

                              (\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE)
                                     BWIDTH)                 (* ; 
                                                           "The new character's correct width")
                                                             (* ; 
                                                        "Make sure that we update imagewidths also")
                              (if IMWIDTHS
                                  then (\FSETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE)
                                                  BWIDTH))
                              (\FSETOFFSET OFFSETS (\CHAR8CODE CHARCODE)
                                     CHAROFFSET)
                              [COND
                                 (DW (for I from 0 to \MAXCHAR
                                        do               (* ; 
 "Run thru the offsets of later characters, adjusting them for the changed width of this character")
                                              (if (IGREATERP (\FGETOFFSET OFFSETS I)
                                                             CHAROFFSET)
                                                  then (\FSETOFFSET OFFSETS I
                                                                  (IPLUS DW (\FGETOFFSET OFFSETS I]
                              (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with 
                                                                                           TEMPBITMAP
                                     )
                              (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with 
                                                                                            NDESCENT)
                              (replace (CHARSETINFO CHARSETASCENT) of CSINFO with NASCENT
                                     )

                              (* ;; "update the properties for the font as a whole.")

                              [SETQ NASCENT (IMAX NASCENT (FONTPROP FONTDESC 'ASCENT]
                              [SETQ NDESCENT (IMAX NDESCENT (FONTPROP FONTDESC 'DESCENT]
                              (replace (FONTDESCRIPTOR \SFAscent) of FONTDESC with 
                                                                                            NASCENT)
                              (replace (FONTDESCRIPTOR \SFDescent) of FONTDESC with
                                                                                       NDESCENT)
                              (replace (FONTDESCRIPTOR \SFHeight) of FONTDESC
                                 with (IPLUS NDESCENT NASCENT)))]
           (RETURN NEWCHARBITMAP])

(MOVECHARBITMAP
  [LAMBDA (SRCECODE SRCEFONT DESTCODE DESTFONT CLIP)     (* ; "Edited 14-Dec-86 18:04 by Shih")

(* ;;; "moves a character from one font to another, clipping if necessary.")

    (PROG ((SRCEDESC (\GETFONTDESC SRCEFONT))
           (DESTDESC (\GETFONTDESC DESTFONT))
           SRCEASCENT SRCEDESCENT DESTASCENT DESTDESCENT CHARBITMAP TEMPBITMAP NEWASCENT NEWDESCENT)
          (SETQ CHARBITMAP (GETCHARBITMAP SRCECODE SRCEFONT))
          (SETQ SRCEASCENT (FONTPROP SRCEDESC 'ASCENT))
          (SETQ DESTASCENT (FONTPROP DESTDESC 'ASCENT))
          (SETQ SRCEDESCENT (FONTPROP SRCEDESC 'DESCENT))
          (SETQ DESTDESCENT (FONTPROP DESTDESC 'DESCENT))
          [SETQ NEWASCENT (COND
                             (CLIP DESTASCENT)
                             (T (IMAX SRCEASCENT DESTASCENT]
          [SETQ NEWDESCENT (COND
                              (CLIP DESTDESCENT)
                              (T (IMAX SRCEDESCENT DESTDESCENT]
          [COND
             ((OR (NEQ SRCEASCENT NEWASCENT)
                  (NEQ SRCEDESCENT NEWDESCENT))
              (SETQ TEMPBITMAP (BITMAPCREATE (BITMAPWIDTH CHARBITMAP)
                                      (IPLUS NEWASCENT NEWDESCENT)))
              (BITBLT CHARBITMAP 0 (IMAX 0 (IDIFFERENCE SRCEDESCENT NEWDESCENT))
                     TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NEWDESCENT SRCEDESCENT))
                     (BITMAPWIDTH CHARBITMAP)
                     (IMIN (IPLUS SRCEASCENT SRCEDESCENT)
                           (IPLUS NEWASCENT NEWDESCENT]
          (PUTCHARBITMAP DESTCODE DESTFONT (OR TEMPBITMAP CHARBITMAP)
                 NEWDESCENT])
)
(DEFINEQ

(FONTCOPY
  [LAMBDA FONTSPECS                                      (* ; "Edited 10-Nov-87 17:12 by FS")
                                                             (* ; 
                                            "makes a copy of a font changing the specified fields.")
    (PROG (NOERROR ERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT)

     (* ;; "Set NOERROR if we find it as a prop, but set ERROR if we find a PROP which is illegal.  Then just return NIL if NOERROR and ERROR, otherwise, call FONTCREATE.")

          [SETQ OLDFONT (\GETFONTDESC (ARG FONTSPECS 1)
                               (AND (type? FONTCLASS (ARG FONTSPECS 1))
                                    (COND
                                       ((AND (EQ FONTSPECS 2)
                                             (LISTP (ARG FONTSPECS 2)))
                                        (LISTGET (ARG FONTSPECS 2)
                                               'DEVICE))
                                       (T (for I from 2 by 2 to FONTSPECS
                                             do (COND
                                                       ((AND (NEQ I FONTSPECS)
                                                             (EQ (ARG FONTSPECS I)
                                                                 'DEVICE))
                                                        (RETURN (ARG FONTSPECS (ADD1 I]
          (SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of OLDFONT))
          (SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of OLDFONT))
          (SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT))
          (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of OLDFONT))
          (SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of OLDFONT))
          [for I VAL from 2 by 2 to FONTSPECS
             do [SETQ VAL (COND
                                 ((NOT (EQ I FONTSPECS))
                                  (ARG FONTSPECS (ADD1 I]
                   (SELECTQ (ARG FONTSPECS I)
                       (FAMILY (SETQ FAMILY VAL))
                       (SIZE (SETQ SIZE VAL))
                       (FACE (SETQ FACE (\FONTFACE VAL)))
                       (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL)))
                       (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL)))
                       (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL)))
                       (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL)))
                       (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL)))
                       (ROTATION (SETQ ROTATION VAL))
                       (DEVICE (SETQ DEVICE VAL))
                       (NOERROR (SETQ NOERROR VAL))
                       (COND
                          [(AND (EQ I 2)
                                (EQ FONTSPECS 2)
                                (LISTP (ARG FONTSPECS 2)))
                           (for J on (ARG FONTSPECS 2) by (CDDR J)
                              do (SETQ VAL (CADR J))
                                    (SELECTQ (CAR J)
                                        (FAMILY (SETQ FAMILY VAL))
                                        (SIZE (SETQ SIZE VAL))
                                        (FACE (SETQ FACE (\FONTFACE VAL)))
                                        (WEIGHT (SETQ FACE (create FONTFACE
                                                              using FACE WEIGHT _ VAL)))
                                        (SLOPE (SETQ FACE (create FONTFACE
                                                             using FACE SLOPE _ VAL)))
                                        (EXPANSION (SETQ FACE (create FONTFACE
                                                                 using FACE EXPANSION _ VAL)))
                                        (BACKCOLOR (SETQ FACE (create FONTFACE
                                                                 using FACE BACKCOLOR _ VAL)))
                                        (FORECOLOR (SETQ FACE (create FONTFACE
                                                                 using FACE FORECOLOR _ VAL)))
                                        (ROTATION (SETQ ROTATION VAL))
                                        (DEVICE (SETQ DEVICE VAL))
                                        (NOERROR (SETQ NOERROR VAL))
                                        (COND
                                           (NOERROR 

                                                  (* ;; 
  "Fell through the SELECTQ, so an illegal PROP.  But, if NOERROR, just note the error, otherwise ")

                                                  (SETQ ERROR T))
                                           (T (\ILLEGAL.ARG (CAR J]
                          (T (if NOERROR
                                 then (SETQ ERROR T)
                               else (\ILLEGAL.ARG (ARG FONTSPECS I]
          (RETURN (if (AND NOERROR ERROR)
                      then NIL
                    else (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR])

(FONTSAVAILABLE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?)
                                                             (* rrb " 7-Nov-84 15:41")

(* ;;; "returns a list of the fonts fitting a description that are available.  FAMILY SIZE FACE or ROTATION can be * which means get them all.  if LOADEDONLYFLG is non-NIL, only fonts in core will be considered.")

    (DECLARE (GLOBALVARS IMAGESTREAMTYPES))
    (PROG (FONTX DEV)
          [SETQ DEV (COND
                       ((type? STREAM DEVICE)
                        (COND
                           ((LISTP (SETQ DEV (IMAGESTREAMTYPE DEVICE)))
                            (CAR DEV))
                           (T DEV)))
                       (DEVICE)
                       (T 'DISPLAY]
          (RETURN
           (COND
              ((LISTP FAMILY)
               (COND
                  ((EQ (CAR FAMILY)
                       'FONT)
                   (SETQ FONTX (CDR FAMILY)))
                  (T (SETQ FONTX FAMILY)))
               (FONTSAVAILABLE (CAR FONTX)
                      (OR (CADR FONTX)
                          SIZE)
                      (OR (CADDR FONTX)
                          FACE)
                      (OR (CADDDR FONTX)
                          ROTATION)
                      DEV CHECKFILESTOO?))
              ([SETQ FONTX (COND
                              ((type? FONTDESCRIPTOR FAMILY)
                               FAMILY)
                              ((NULL FAMILY)
                               (DEFAULTFONT DEV))
                              ((type? FONTCLASS FAMILY)

                               (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.  Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.")
                                                             (* ; 
                                                       "I don't know what to do in this case- rrb.")
                               (\COERCEFONTDESC FAMILY DEV T))
                              ((OR (IMAGESTREAMP FAMILY)
                                   (type? WINDOW FAMILY))
                               (DSPFONT NIL FAMILY]          (* ; 
                 "FAMILY was a spec for a font descriptor, use it and extend it by the other args.")
               (FONTSAVAILABLE (FONTPROP FONTX 'FAMILY)
                      (OR SIZE (FONTPROP FONTX 'SIZE))
                      (OR FACE (FONTPROP FONTX 'FACE))
                      (OR ROTATION (FONTPROP FONTX 'ROTATION))
                      (OR DEVICE (FONTPROP FONTX 'DEVICE))
                      CHECKFILESTOO?))
              (T (PROG ((FONTFACE FACE))
                   RETRY
                       (OR (LITATOM FAMILY)
                           (LISPERROR "ARG NOT LITATOM" FAMILY T))
                       (OR (AND (FIXP SIZE)
                                (IGREATERP SIZE 0))
                           (EQ SIZE '*)
                           (\ILLEGAL.ARG SIZE))
                       [OR (EQ FONTFACE '*)
                           (SETQ FONTFACE (OR (\FONTFACE FACE T)
                                              (RETURN NIL]
                       (OR (U-CASEP FAMILY)
                           (SETQ FAMILY (U-CASE FAMILY)))
                       (COND
                          ((NULL ROTATION)
                           (SETQ ROTATION 0))
                          ((AND (FIXP ROTATION)
                                (IGEQ ROTATION 0)))
                          ((EQ ROTATION '*))
                          (T (\ILLEGAL.ARG ROTATION)))
                       (RETURN (UNION (\LOOKUPFONTSINCORE FAMILY SIZE FONTFACE ROTATION DEV)
                                      (COND
                                         ((NOT CHECKFILESTOO?)
                                          NIL)
                                         [(EQ DEV '*)        (* ; "map thru all the devices.")
                                          (for EXTANTDEV in IMAGESTREAMTYPES
                                             join (APPLY* (OR (CADR (ASSOC 'FONTSAVAILABLE
                                                                               (CDR EXTANTDEV)))
                                                                  (FUNCTION NILL))
                                                             FAMILY SIZE FONTFACE ROTATION
                                                             (CAR EXTANTDEV]
                                         (T                  (* ; 
                                                           "apply the device font lookup function.")
                                            (APPLY* (OR [CADR (ASSOC 'FONTSAVAILABLE
                                                                     (CDR (ASSOC DEV IMAGESTREAMTYPES
                                                                                 ]
                                                        (FUNCTION NILL))
                                                   FAMILY SIZE FONTFACE ROTATION DEV])

(FONTFILEFORMAT
  [LAMBDA (STRM LEAVEOPEN)                               (* rmk%: "11-Sep-84 17:16")
                                                             (* ; "Returns the font format of STRM")
    [OR (OPENP STRM 'INPUT)
        (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD]
    (PROG1 (SELECTC (\WIN STRM)
               ((LIST (LLSH 1 15)
                      (LOGOR (LLSH 1 15)
                             (LLSH 1 13))) 

                                 (* ;; "If high bit of type is on, then must be strike.  If 2nd bit is on, must be strike-index, and we punt.  We don't care about the 3rd bit")

                    
                    (* ;; "first word has high bits (onebit index fixed).  Onebit means 'new-style font' , index is 0 for simple strike, 1 for index, and fixed is if all chars have max width.  Lisp doesn't care about 'fixed'")

                    'STRIKE)
               ((LOGOR (LLSH 16 8)
                       12) 
                           (* ;; "This is the length of a standard index header.  Other files could also have this value, but it's a pretty good discriminator")

                    
                    (* ;; "Skip to byte 25;  do it with BINS so works for non-randaccessp devices.  This skips the standard name header, then look for type 3 in the following header")

                    (FRPTQ 22 (\BIN STRM))                   (* ; "(SETFILEPTR STRM 25)")
                    (AND (EQ 3 (LRSH (\BIN STRM)
                                     4))
                         'AC))
               NIL)
        (OR LEAVEOPEN (CLOSEF STRM)))])

(FONTP
  [LAMBDA (X)                                            (* rmk%: "13-Sep-84 09:04")
                                                             (* ; "is X a FONTDESCRIPTOR?")
    (COND
       ((OR (type? FONTDESCRIPTOR X)
            (type? FONTCLASS X))
        X])

(FONTUNPARSE
  [LAMBDA (FONT)                                         (* kbr%: "25-Feb-86 19:40")

    (* ;; "Produces a minimal specification of the font or fontclass specification, for dumping by Tedit, imageobjects.")

    (PROG (FACE SPEC)
          (SETQ SPEC (COND
                        ((type? FONTDESCRIPTOR FONT)
                         (FONTPROP FONT 'SPEC))
                        [(type? FONTCLASS FONT)
                         (RETURN (CONS 'CLASS (FONTCLASSUNPARSE FONT]
                        (T 
                           (* ;; "Could be a non-instantiated specification in a fontclass, just use it as the spec without creating the font.")

                           FONT)))
          (OR SPEC (RETURN))
          (SETQ FACE (CADDR SPEC))                           (* ; 
                        "FACE and rotation can be NIL for a non-fontdescriptor fontclass component")
          [SETQ FACE (COND
                        ([OR (NULL FACE)
                             (EQUAL FACE '(MEDIUM REGULAR REGULAR]
                         NIL)
                        ((LITATOM FACE)
                         FACE)
                        [(LISTP FACE)
                         (PACK (LIST* (NTHCHAR (fetch (FONTFACE WEIGHT) of FACE)
                                             1)
                                      (NTHCHAR (fetch (FONTFACE SLOPE) of FACE)
                                             1)
                                      (NTHCHAR (fetch (FONTFACE EXPANSION) of FACE)
                                             1)
                                      (COND
                                         ((fetch (FONTFACE COLOR) of FACE)
                                          (LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE)
                                                "-"
                                                (fetch (FONTFACE FORECOLOR) of FACE]
                        (T (SHOULDNT]                        (* ; 
                                                    "Don't return device, or any trailing defaults")
          (RETURN (CONS (CAR SPEC)
                        (CONS (CADR SPEC)
                              (COND
                                 ([AND (CADDDR SPEC)
                                       (NOT (EQ 0 (CADDDR SPEC]
                                  (LIST (OR FACE 'MRR)
                                        (CADDDR SPEC)))
                                 (FACE (CONS FACE])

(SETFONTDESCRIPTOR
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT)        (* ; "Edited  1-Aug-88 16:16 by rmk:")
                                                             (* ; "Edited  5-Mar-87 19:28 by FS")

    (* ;; "saves a font descriptor under a family/size/face/rotation/device key so that it will be retreived by FONTCREATE.  This is a user entry.")

    (DECLARE (GLOBALVARS \FONTSINCORE))
    (SETQ DEVICE (\DEVICESYMBOL DEVICE))                 (* ; "Unpackageify")
    (AND FONT (SETQ FONT (\COERCEFONTDESC FONT DEVICE))) (* ; 
                            "NIL is used to clobber existing font so that next use will reread it.")
    (SETQ FAMILY (\FONTSYMBOL FAMILY))                   (* ; "Unpackageify")
    (SETQ FACE (\FONTFACE FACE NIL DEVICE))
    (OR ROTATION (SETQ ROTATION 0))
    (OR (AND (FIXP SIZE)
             (IGEQ SIZE 0))
        (\ILLEGAL.ARG SIZE))
    (PROG [(X (OR (FASSOC FAMILY \FONTSINCORE)
                  (CAR (push \FONTSINCORE (LIST FAMILY]
          [SETQ X (OR (FASSOC SIZE (CDR X))
                      (CAR (push (CDR X)
                                  (LIST SIZE]
          [SETQ X (OR (SASSOC FACE (CDR X))
                      (CAR (push (CDR X)
                                  (LIST FACE]                (* ; "SASSOC cause FACE is listp")
          [SETQ X (OR (FASSOC ROTATION (CDR X))
                      (CAR (push (CDR X)
                                  (LIST ROTATION]
          [SETQ X (OR (FASSOC DEVICE (CDR X))
                      (CAR (push (CDR X)
                                  (LIST DEVICE]
          (RPLACD X FONT)
          (RETURN FONT])

(CHARCODEP
  [LAMBDA (CHCODE)                                       (* gbn "22-Jul-85 16:35")
                                                             (* ; 
                                                           "is CHCODE a legal character code?")
    (AND (SMALLP CHCODE)
         (IGEQ CHCODE 0)
         (ILEQ CHCODE \MAXNSCHAR])

(EDITCHAR
  [LAMBDA (CHARCODE FONT)                                (* rrb "24-MAR-82 12:22")
                                                             (* ; 
                                                 "calls the bitmap editor on a character of a font")
    (PROG ((FONTDESC (\GETFONTDESC FONT)))
          (RETURN (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC])

(\STREAMCHARWIDTH
  [LAMBDA (CHARCODE STREAM TTBL)                         (* JonL " 8-NOV-83 03:31")

    (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for the various escape sequences.  Used by \ECHOCHAR")

    (SETQ CHARCODE (LOGAND CHARCODE \CHARMASK))
    ((LAMBDA (WIDTHSVECTOR)

       (* ;; "Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean that the character's glyph simply isn't loaded;  e.g., it may want #^A")

       (SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM)
                                   (SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM))
                                   (ffetch DDWIDTHSCACHE of WIDTHSVECTOR))
                              \UNITWIDTHSVECTOR))
       (SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA)
                                                      of (OR (TERMTABLEP TTBL)
                                                                 \PRIMTERMTABLE))
                                                CHARCODE))
           (INDICATE.CCE ([LAMBDA (CC)
                            (IPLUS (if (IGEQ CHARCODE (CHARCODE %#^@))
                                       then              (* ; 
                                          "A META charcode -- implies that the 8th bit is non-zero")
                                             (SETQ CC (LOADBYTE CHARCODE 0 7))
                                             (\FGETWIDTH WIDTHSVECTOR (CHARCODE %#))
                                     else 0)
                                   (if (ILESSP CC (CHARCODE SPACE))
                                       then              (* ; "A CONTROL charcode")
                                             (add CC (CONSTANT (LLSH 1 6)))
                                             (\FGETWIDTH WIDTHSVECTOR (CHARCODE ^))
                                     else 0)
                                   (\FGETWIDTH WIDTHSVECTOR CC]
                          CHARCODE))
           (SIMULATE.CCE (SELCHARQ CHARCODE
                              ((EOL CR LF BELL) 
                                   NIL)
                              (ESCAPE (\FGETWIDTH WIDTHSVECTOR (CHARCODE $)))
                              (TAB (PROG ((SPACEWIDTH (\FGETWIDTH WIDTHSVECTOR (CHARCODE SPACE)))
                                          (NEWXPOSITON (DSPXPOSITION NIL STREAM))
                                          TABWIDTH)
                                         (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
                                         [add NEWXPOSITON (SETQ TABWIDTH
                                                               (IDIFFERENCE
                                                                TABWIDTH
                                                                (IMOD (IDIFFERENCE NEWXPOSITON
                                                                             (DSPLEFTMARGIN NIL 
                                                                                    STREAM))
                                                                      TABWIDTH]
                                         (RETURN (if (IGREATERP NEWXPOSITON (DSPRIGHTMARGIN
                                                                                 NIL STREAM))
                                                     then 
                                                             (* ; 
                                                           "tab was past rightmargin, force cr.")
                                                           NIL
                                                   else TABWIDTH))))
                              (\FGETWIDTH WIDTHSVECTOR CHARCODE)))
           (REAL.CCE (SELECTC CHARCODE
                         ((CHARCODE (EOL CR LF)) 
                              NIL)
                         (ERASECHARCODE NIL)
                         (\FGETWIDTH WIDTHSVECTOR CHARCODE)))
           (IGNORE.CCE 0)
           (SHOULDNT])

(\UNITWIDTHSVECTOR
  [LAMBDA NIL                                            (* JonL " 7-NOV-83 19:23")
    (SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXCHAR 3)
                                                WORDSPERCELL)))
    (for I from 0 to (IPLUS \MAXCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1))
    \UNITWIDTHSVECTOR])

(\CREATEDISPLAYFONT
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)     (* gbn%: "25-Jan-86 18:02")
    (PROG [(FONTDESC (create FONTDESCRIPTOR
                            FONTDEVICE _ DEVICE
                            FONTFAMILY _ FAMILY
                            FONTSIZE _ SIZE
                            FONTFACE _ FACE
                            \SFAscent _ 0
                            \SFDescent _ 0
                            \SFHeight _ 0
                            ROTATION _ ROTATION
                            FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE]
          (RETURN (COND
                     ((\GETCHARSETINFO CHARSET FONTDESC T)
                      FONTDESC)
                     (T NIL])

(\CREATECHARSET.DISPLAY
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
                                                             (* ; "Edited 14-Jan-88 23:42 by FS")

    (* ;; "Color Stuff removed  -FS.")

    (* ;; "Replace Cond below with")

    (* ;; "(PROG (XCSINFO)")

    (* ;; "(SETQ XCSINFO &)")

    (* ;; "(COND ((FMEMB DEVICE \\COLORDISPLAYSTREAMTYPES) (SETQ XCSINFO (\\SFMAKECOLOR XCSINFO (OR (|fetch| (FONTFACE BACKCOLOR) |of| FACE) 0) (OR (|fetch| (FONTFACE FORECOLOR) |of| FACE) (MAXIMUMCOLOR (\\DISPLAYSTREAMTYPEBPP DEVICE))) (\\DISPLAYSTREAMTYPEBPP DEVICE)))))")

    (* ;; "(RETURN XCSINFO)))")

(* ;;; "tries to build the csinfo required for CHARSET.  Does the necessary coercions.")

(* ;;; 
"NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")

    (DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS))

    (* ;; "DISPLAYFONTCOERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...).  Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a similar list.")

    (COND
       ((PROG1 (for TRANSL in DISPLAYFONTCOERCIONS bind NEWCSINFO UFONT REALFONT
                  when (AND (SETQ UFONT (CAR TRANSL))
                                (EQ FAMILY (CAR UFONT))
                                (OR (NOT (CADR UFONT))
                                    (EQ SIZE (CADR UFONT)))
                                (OR (NOT (CADDR UFONT))
                                    (EQ CHARSET (CADDR UFONT)))
                                (SETQ REALFONT (CADR TRANSL))
                                (SETQ NEWCSINFO (\CREATECHARSET.DISPLAY (OR (CAR REALFONT)
                                                                                FAMILY)
                                                       (OR (CADR REALFONT)
                                                           SIZE)
                                                       FACE ROTATION DEVICE (OR (CADDR REALFONT)
                                                                                CHARSET)
                                                       FONTDESC NOSLUG?))) do (RETURN NEWCSINFO))
                                                             (* ; 
                        "Just recursively call ourselves to handle entries in DISPLAYFONTCOERCIONS")
               ))
       (T 
          (* ;; "One weirdness is, if you have a coercion, and the real-font is missing, you can't get a missingfont coercion on the user-font because the real-font missingfont coercion shadows it out.")

          (\CREATE-REAL-CHARSET.DISPLAY FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?
                 ])

(\CREATE-REAL-CHARSET.DISPLAY
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
                                                             (* ; "Edited 15-Jan-88 00:02 by FS")
    (COND
       [(AND (EQ ROTATION 0)
             (PROG1 (\READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION 'DISPLAY CHARSET)
                                                             (* ; 
 "If it is available, this will force the appropriate file to be read to fill in the charset entry")
                    ]
       (T 
          (* ;; "if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised 'by hand'.  Past that point, we do not allow DISPLAYFONTCOERCIONS, only MISSINGxxxxDISPLAYFONTCOERCIONS.")

          (PROG (NEWFONT XFONT XLATEDFAM CSINFO)
                (RETURN (COND
                           [(NEQ ROTATION 0)

                            (* ;; "to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.  If its still missing, then search for missing display font coercions (e.g. no avail. charset, *but*, do not recurse (avoid getting into infinite loops).  This allows partial permutations of fonts.")

                            (OR (MEMB ROTATION '(90 270))
                                (ERROR "only implemented rotations are 0, 90 and 270." ROTATION))
                            (COND
                               ((SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE FACE 0 'DISPLAY 
                                                   CHARSET))

                                (* ;; "Do not call FONTCREATE here.  The user might have modified (via PUTCHARBITMAP, etc.) the in-memory version of the source.  This also fixes a bug in which several font descriptors ended up sharing bitmaps or charsetvectors, causing havoc when the user modifies either fontdescriptor.")

                                (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
                                    then (\SFROTATECSINFO CSINFO ROTATION)
                                  else NIL]
                           ((AND (EQ (fetch WEIGHT of FACE)
                                     'BOLD)
                                 (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE
                                                    (create FONTFACE using FACE WEIGHT _
                                                                               'MEDIUM)
                                                    0
                                                    'DISPLAY CHARSET)))

                            (* ;; "if we want a bold font, and the medium weight font is available, build the medium weight version then call \SFMAKEBOLD on the csinfo")

                            (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
                                then (\SFMAKEBOLD CSINFO)
                              else NIL))
                           ((AND (EQ (fetch (FONTFACE SLOPE) of FACE)
                                     'ITALIC)
                                 (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE
                                                    (create FONTFACE using FACE SLOPE _
                                                                               'REGULAR)
                                                    0
                                                    'DISPLAY CHARSET)))
                            (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
                                then (\SFMAKEITALIC CSINFO)
                              else NIL))
                           [(AND CHARSET (NOT (EQL 0))
                                 (for TRANSL in MISSINGCHARSETDISPLAYFONTCOERCIONS
                                    bind NEWCSINFO UFONT REALFONT
                                    when (AND (SETQ UFONT (CAR TRANSL))
                                                  (EQ FAMILY (CAR UFONT))
                                                  (OR (NOT (CADR UFONT))
                                                      (EQ SIZE (CADR UFONT)))
                                                  (OR (NOT (CADDR UFONT))
                                                      (EQ CHARSET (CADDR UFONT)))
                                                  (SETQ REALFONT (CADR TRANSL))
                                                  (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY
                                                                   (OR (CAR REALFONT)
                                                                       FAMILY)
                                                                   (OR (CADR REALFONT)
                                                                       SIZE)
                                                                   FACE ROTATION DEVICE
                                                                   (OR (CADDR REALFONT)
                                                                       CHARSET)
                                                                   FONTDESC NOSLUG?)))
                                    do (RETURN NEWCSINFO]
                           ((for TRANSL in MISSINGDISPLAYFONTCOERCIONS bind NEWCSINFO 
                                                                                     UFONT REALFONT
                               when (AND (SETQ UFONT (CAR TRANSL))
                                             (EQ FAMILY (CAR UFONT))
                                             (OR (NOT (CADR UFONT))
                                                 (EQ SIZE (CADR UFONT)))
                                             (OR (NOT (CADDR UFONT))
                                                 (EQ CHARSET (CADDR UFONT)))
                                             (SETQ REALFONT (CADR TRANSL))
                                             (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY
                                                              (OR (CAR REALFONT)
                                                                  FAMILY)
                                                              (OR (CADR REALFONT)
                                                                  SIZE)
                                                              FACE ROTATION DEVICE
                                                              (OR (CADDR REALFONT)
                                                                  CHARSET)
                                                              FONTDESC NOSLUG?)))
                               do (RETURN NEWCSINFO)))
                           ((NOT NOSLUG?)
                            (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
                                                     of FONTDESC)
                                   (FONTPROP FONTDESC 'ASCENT)
                                   (FONTPROP FONTDESC 'DESCENT)
                                   (FONTPROP FONTDESC 'DEVICE])

(\BUILDSLUGCSINFO
  [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE)            (* ; "Edited  9-May-93 23:12 by rmk:")

(* ;;; "builds a csinfo which contains only the slug (black rectangle) character.  Called only for display.")

    (SETQ SCALE (OR SCALE 1))
    (PROG ((CSINFO (create CHARSETINFO
                          CHARSETASCENT _ ASCENT
                          CHARSETDESCENT _ DESCENT))
           WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
          (REPLACE IMAGEWIDTHS OF CSINFO WITH WIDTHS)
          (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (
                                                                                 \CREATECSINFOELEMENT
                                                                                   )))
          (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
          [replace (CHARSETINFO CHARSETBITMAP) of CSINFO
             with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE))
                                          (ROUND (QUOTIENT (IPLUS ASCENT DESCENT)
                                                        SCALE]
          [BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE]
          (RETURN CSINFO])

(\SEARCHDISPLAYFONTFILES
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)             (* ; "Edited  5-Mar-87 18:55 by FS")

    (* ;; "     This function called via APPLY in IMAGESTREAMTYPES.")

    (* ;; "     Returns a list of the fonts that can be read in for displaylike devices.  Rotation is ignored because it is assumed that all devices support 0 90 and 270.")

    (* ;; "     Note we *allow* a device that is not 'DISPLAY for guys like 4DISPLAY, 8DISPLAY, 24DISPLAY, and also possibly for FX80,  etc. (guys that want DISPLAYFONTS anyway).  Should have some hook though for FONTEXTENSIONS, FONTDIRECTORIES??")

    (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
    (SELECTQ (SYSTEMTYPE)
        (D (\SEARCHFONTFILES FAMILY SIZE FACE ROTATION DEVICE DISPLAYFONTDIRECTORIES 
                  DISPLAYFONTEXTENSIONS))
        (J                                                   (* OLD J code from \READDISPLAYFONT
                                                           (PROG ((FONTFILE (\FONTFILENAME 
                                                           FAMILY SIZE FACE)) FONTDESC STRM)
                                                           (COND ((SETQ STRM (AND 
                                                           FONTDIRECTORIES (FINDFILE FONTFILE T 
                                                           FONTDIRECTORIES)))
                                                           (SETQ STRM (OPENSTREAM FONTFILE
                                                           (QUOTE INPUT))) (SETQ FONTDESC
                                                           (\READJERICHOFONTFILE FAMILY SIZE 
                                                           FACE STRM)) (CLOSEF STRM)))
                                                           (RETURN FONTDESC)))
           NIL)
        (SHOULDNT])

(\SEARCHFONTFILES
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST)   (* ; "Edited 14-Sep-96 10:54 by rmk:")
                                                             (* ; "Edited  6-Oct-89 12:34 by bvm")

    (* ;; "GENERIC FUNCTION")

    (* ;; "returns a list of the fonts that can be read in for a device.  Rotation is ignored because it is assumed that all devices support 0 90 and 270.")

    (SETQ FAMILY (\FONTSYMBOL FAMILY))
    (SETQ DEVICE (\FONTSYMBOL DEVICE))
    (SETQ FACE (\FONTFACE FACE))
    (BIND (FILING.ENUEMRATION.DEPTH _ 1)
           FONTSFOUND THISFONT THISFACE FOR E INSIDE EXTLST
       DO [FOR DIR INSIDE DIRLST
                 BIND (FILEPATTERN _ (IF (FMEMB E *OLD-FONT-EXTENSIONS*)
                                             THEN (\FONTFILENAME.OLD FAMILY SIZE FACE E)
                                           ELSE (\FONTFILENAME FAMILY SIZE FACE E)))
                 DO 

                       (* ;; "Hack above to handle both old and new font file names.  The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup.  If set to a list of extensions, just those will be looked up with old-style  conventions")

                       (FOR FONTFILE IN (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR
                                                                  'BODY FILEPATTERN))
                          WHEN [PROGN (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE DEVICE))
                                          (SETQ THISFACE (CADDR THISFONT))

                                          (* ;; 
                                        "make sure the face, size, and family really match.")

                                          (AND (NOT (MEMBER THISFONT FONTSFOUND))
                                               (OR (EQ FAMILY '*)
                                                   (EQ FAMILY (CAR THISFONT)))
                                               (OR (EQ SIZE '*)
                                                   (EQ SIZE (CADR THISFONT)))
                                               (OR (EQ FACE '*)
                                                   (EQUAL FACE THISFACE)
                                                   (AND (OR (EQ (CAR FACE)
                                                                '*)
                                                            (EQ (CAR FACE)
                                                                (CAR THISFACE)))
                                                        (OR (EQ (CADR FACE)
                                                                '*)
                                                            (EQ (CADR FACE)
                                                                (CADR THISFACE)))
                                                        (OR (EQ (CADDR FACE)
                                                                '*)
                                                            (EQ (CADDR FACE)
                                                                (CADDR THISFACE]
                          DO (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
       FINALLY (RETURN FONTSFOUND])

(\FINDFONTFILE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST)
                                                             (* ; "Edited 14-Sep-96 10:53 by rmk:")
                                                             (* ; "Edited  6-Oct-89 11:18 by bvm")

    (* ;; "Find any font file on any directory with any naming convention with any extension.  Note that ROTATION and DEVICE are just place holders.   DEVICE is irrelevant because DIRLST already incorporates the device information.  The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup.  If set to a list of extensions, just those will be looked up with old-style conventions.")

    (BIND FONTFILE FOR EXT INSIDE EXTLST
       WHEN (SETQ FONTFILE (FINDFILE (IF (FMEMB EXT *OLD-FONT-EXTENSIONS*)
                                             THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT 
                                                             CHARSET)
                                           ELSE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET))
                                      T DIRLST)) DO (RETURN FONTFILE])

(\FONTSYMBOL
  [LAMBDA (X ElseReturnXFlg)                             (* ; "Edited 28-Jul-88 11:59 by rmk:")
                                                             (* ; "Edited 24-Mar-87 14:32 by FS")

    (* ;; "Return a symbol in IL package and is in uppercase.  Currently the function IL:U-CASE is believed to do this, but if it changes, this is the font hook.  ElseReturnXFlg is if you want an IL symbol if X is a symbol or string, otherwise just X.")

    (COND
       ((LITATOM X)
        (U-CASE X))
       ((STRINGP X)
        (MKATOM (U-CASE X)))
       (ElseReturnXFlg X)
       (T (ERROR "Want an IL symbol"])

(\DEVICESYMBOL
  [LAMBDA (X ElseReturnXFlg)                             (* ; "Edited  7-Oct-88 20:07 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:43 by rmk:")
                                                             (* ; "Edited 24-Mar-87 14:33 by FS")

    (* ;; "Return a canonicalized atom good for comparing with DEVICE symbols")

    (LET ((STRM (\GETSTREAM X 'OUTPUT T)))
         (COND
            (STRM (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of
                                                                                         STRM)))
            ((NULL X)
             'DISPLAY)
            (T                                               (* ; "because its used in ASSOC.")
               (\FONTSYMBOL X ElseReturnXFlg])

(\FONTFACE
  [LAMBDA (FACE NOERRORFLG DEV)                          (* ; "Edited  1-Aug-88 09:44 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:50 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:49 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:41 by rmk:")
                                                             (* ; "Edited 28-Jul-88 15:38 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")
                                                             (* ; "Edited 25-Feb-87 22:58 by FS")

    (* ;; "Coerces FACE into standard FONTFACE record, usually returns a CONSTANT (so you'd better not RPLACD or REPLACE fields!!)")

    (PROG (UNKNOWN (WEIGHT 'MEDIUM)
                 (SLOPE 'REGULAR)
                 (EXPANSION 'REGULAR)
                 (OLDFACE FACE))

     (* ;; "On error, can signal, or return NIL, or return REGULAR face.")

          [SETQ UNKNOWN (COND
                           ((EQ NOERRORFLG 'REGULAR)
                            'REGULAR)
                           (T 'ERROR]
          [COND
             ((type? FONTFACE FACE)

              (* ;; "List Case.  Unpack because want to validate fields")

              (SETQ WEIGHT (fetch (FONTFACE WEIGHT) of FACE))
              (SETQ SLOPE (fetch (FONTFACE SLOPE) of FACE))
              (SETQ EXPANSION (fetch (FONTFACE EXPANSION) of FACE))

              (* ;; "Handle unknown faces")

              [OR (\FONT.SYMBOLMEMB WEIGHT '             (* BOLD MEDIUM LIGHT))
                  (SETQ WEIGHT (COND
                                  ((\FONT.COMPARESYMBOL WEIGHT 'REGULAR)

                                   (* ;; "Clean up WEIGHT REGULAR vs. MEDIUM")

                                   (SETQ WEIGHT 'MEDIUM))
                                  (T UNKNOWN]
              (OR (\FONT.SYMBOLMEMB SLOPE '              (* REGULAR ITALIC))
                  (SETQ SLOPE UNKNOWN))
              (OR (\FONT.SYMBOLMEMB EXPANSION '          (* COMPRESSED REGULAR EXPANDED))
                  (SETQ EXPANSION UNKNOWN)))
             ((OR (LITATOM FACE)
                  (STRINGP FACE))
              (COND
                 ((NULL FACE)                                (* ; "Fast vanilla default")
                  )
                 ((EQ (NCHARS FACE)
                      3)                                     (* ; "3 char notation case")
                  (SETQ WEIGHT (SELCHARQ (CHCON1 FACE)
                                    ((B b) 
                                         'BOLD)
                                    ((M m R r) 
                                         'MEDIUM)
                                    ((L l) 
                                         'LIGHT)
                                    UNKNOWN))
                  (SETQ SLOPE (SELCHARQ (NTHCHARCODE FACE 2)
                                   ((R r) 
                                        'REGULAR)
                                   ((I i) 
                                        'ITALIC)
                                   UNKNOWN))
                  (SETQ EXPANSION (SELCHARQ (NTHCHARCODE FACE 3)
                                       ((R r) 
                                            'REGULAR)
                                       ((C c) 
                                            'COMPRESSED)
                                       ((E e) 
                                            'EXPANDED)
                                       UNKNOWN)))
                 ((SELECTQ FACE
                      (BOLD (SETQ WEIGHT 'BOLD))
                      (ITALIC (SETQ SLOPE 'ITALIC))
                      (BOLDITALIC (SETQ WEIGHT 'BOLD)
                                  (SETQ SLOPE 'ITALIC))
                      ((STANDARD REGULAR) 
                           T)
                      NIL))
                 ((\FONT.COMPARESYMBOL FACE 'BOLD)
                  (SETQ WEIGHT 'BOLD))
                 ((\FONT.COMPARESYMBOL FACE 'ITALIC)
                  (SETQ SLOPE 'ITALIC))
                 ((\FONT.COMPARESYMBOL FACE 'BOLDITALIC)
                  (SETQ WEIGHT 'BOLD)
                  (SETQ SLOPE 'ITALIC))
                 ((\FONT.SYMBOLMEMB FACE '(STANDARD REGULAR NIL NNN))
                                                             (* ; "Vanilla case")
                  )
                 ((STRPOS "-" FACE)                          (* ; "Color fontface spec!")
                  (SETQ FACE (\FONTFACE.COLOR FACE NOERRORFLG DEV))
                  (RETURN FACE))
                 ((\FONT.SYMBOLMEMB FACE '               (* ***))
                                                             (* ; "Wildcard case")
                  (SETQ WEIGHT '*)
                  (SETQ SLOPE '*)
                  (SETQ EXPANSION '*))
                 (T                                          (* ; "Other litatom error case")
                    (SETQ WEIGHT UNKNOWN)
                    (SETQ SLOPE UNKNOWN)
                    (SETQ EXPANSION UNKNOWN]
          (if (OR (EQ WEIGHT 'ERROR)
                      (EQ SLOPE 'ERROR)
                      (EQ EXPANSION 'ERROR))
              then (if NOERRORFLG
                           then (RETURN NIL)
                         else (\ILLEGAL.ARG OLDFACE)))

     (* ;; "Avoid consing by returning constant faces (historical:  really, would have been better to return MRR, but users have know about this for too long (rmk))")

          (RETURN (COND
                     ((AND (EQ WEIGHT 'MEDIUM)
                           (EQ SLOPE 'REGULAR)
                           (EQ EXPANSION 'REGULAR))          (* ; "MRR")
                      (CONSTANT (create FONTFACE)))
                     [(AND (EQ WEIGHT 'BOLD)
                           (EQ SLOPE 'REGULAR)
                           (EQ EXPANSION 'REGULAR))          (* ; "BRR")
                      (CONSTANT (create FONTFACE
                                       WEIGHT _ 'BOLD]
                     [(AND (EQ WEIGHT 'MEDIUM)
                           (EQ SLOPE 'ITALIC)
                           (EQ EXPANSION 'REGULAR))          (* ; "MIR")
                      (CONSTANT (create FONTFACE
                                       SLOPE _ 'ITALIC]
                     [(AND (EQ WEIGHT 'BOLD)
                           (EQ SLOPE 'ITALIC)
                           (EQ EXPANSION 'REGULAR))          (* ; "BIR")
                      (CONSTANT (create FONTFACE
                                       WEIGHT _ 'BOLD
                                       SLOPE _ 'ITALIC]
                     (T                                      (* ; "Otherwise, cons up")
                        (create FONTFACE
                               WEIGHT _ WEIGHT
                               SLOPE _ SLOPE
                               EXPANSION _ EXPANSION])

(\FONTFACE.COLOR
  [LAMBDA (FACE NOERRORFLG DEV)                          (* ; "Edited 28-Jul-88 14:51 by rmk:")
                                                             (* ; "Edited 28-Jul-88 13:09 by rmk:")
                                                             (* ; "Edited 24-Mar-87 17:03 by FS")

    (* ;; "This used to be \FONTFACE.  Renamed \FONTFACE.COLOR, and \FONTFACE rewritten.  The section below should also be redone")

    (* ;; "Takes a variety of user specifications and converts them to a standard FONTFACE record.")

    (* ;; "b/w fontfaces are extended by an optional '-backcolor-forecolor'")

    (* ;; "the atom NNN is interpreted the same as NIL or MRR to cover up a bug described in AR 3025, the FONTNNN bug")

    (DECLARE (GLOBALVARS \COLORDISPLAYSTREAMTYPES))
    (SETQ DEV (\DEVICESYMBOL DEV))
    (PROG (BWFACE POS OLDPOS BITSPERPIXEL BACKCOLOR FORECOLOR ANSWER)

     (* ;; "First get a FONTFACE ANSWER.")

          [SETQ ANSWER (COND
                          ((type? FONTFACE FACE)
                           FACE)
                          ((LITATOM FACE)
                           (OR (U-CASEP FACE)
                               (SETQ FACE (U-CASE FACE)))
                           (SETQ POS (STRPOS "-" FACE))
                           (COND
                              [POS (SETQ BWFACE (SUBATOM FACE 1 (SUB1 POS]
                              (T (SETQ BWFACE FACE)))
                           [SETQ ANSWER (SELECTQ BWFACE
                                            ((* ***) 
                                                 (CONSTANT (create FONTFACE
                                                                  WEIGHT _ '*
                                                                  SLOPE _ '*
                                                                  EXPANSION _ '*)))
                                            ((NIL MRR STANDARD NNN) 
                                                 (CONSTANT (create FONTFACE)))
                                            ((ITALIC MIR) 
                                                 (CONSTANT (create FONTFACE
                                                                  SLOPE _ 'ITALIC)))
                                            ((BOLD BRR) 
                                                 (CONSTANT (create FONTFACE
                                                                  WEIGHT _ 'BOLD)))
                                            ((BOLDITALIC BIR) 
                                                 (CONSTANT (create FONTFACE
                                                                  WEIGHT _ 'BOLD
                                                                  SLOPE _ 'ITALIC)))
                                            (create FONTFACE
                                                   WEIGHT _ (SELCHARQ (NTHCHARCODE FACE 1)
                                                                 (M 'MEDIUM)
                                                                 (B 'BOLD)
                                                                 (L 'LIGHT)
                                                                 (GO ERROR))
                                                   SLOPE _ (SELCHARQ (NTHCHARCODE FACE 2)
                                                                (R 'REGULAR)
                                                                (I 'ITALIC)
                                                                (GO ERROR))
                                                   EXPANSION _ (SELCHARQ (NTHCHARCODE FACE 3)
                                                                    (R 'REGULAR)
                                                                    (C 'COMPRESSED)
                                                                    (E 'EXPANDED)
                                                                    (GO ERROR]
                           (COND
                              (POS                           (* ; "Color FONTFACE.  *")
                                   (SETQ OLDPOS POS)
                                   (SETQ POS (STRPOS "-" FACE (ADD1 OLDPOS)))
                                   (COND
                                      ((NULL POS)
                                       (GO ERROR)))
                                   (SETQ BITSPERPIXEL (\DISPLAYSTREAMTYPEBPP DEV))
                                   (SETQ BACKCOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
                                                                        (SUB1 POS))
                                                          BITSPERPIXEL))
                                   (SETQ OLDPOS POS)
                                   (SETQ FORECOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
                                                                        -1)
                                                          BITSPERPIXEL))
                                                             (* ; 
                                                         "COPY ANSWER to avoid smashing constants.")
                                   (SETQ ANSWER (COPY ANSWER))
                                   (replace (FONTFACE BACKCOLOR) of ANSWER with BACKCOLOR
                                          )
                                   (replace (FONTFACE FORECOLOR) of ANSWER with FORECOLOR
                                          )))
                           ANSWER)
                          (T (GO ERROR]

     (* ;; "Coerce on or off COLOR.")

          (SETQ ANSWER (COND
                          ((AND (NOT (FMEMB DEV \COLORDISPLAYSTREAMTYPES))
                                (fetch (FONTFACE COLOR) of ANSWER))
                           (SETQ ANSWER (COPY ANSWER))
                           (replace (FONTFACE COLOR) of ANSWER with NIL)
                           ANSWER)
                          ((AND (FMEMB DEV \COLORDISPLAYSTREAMTYPES)
                                (NULL (fetch (FONTFACE COLOR) of ANSWER)))
                           (SETQ FACE (COPY FACE))
                           (replace (FONTFACE BACKCOLOR) of ANSWER with 0)
                           (replace (FONTFACE FORECOLOR) of ANSWER with
                                                                           (MAXIMUMCOLOR (
                                                                                \DISPLAYSTREAMTYPEBPP
                                                                                          DEV)))
                           ANSWER)
                          (T ANSWER)))
          (RETURN ANSWER)
      ERROR
          (COND
             (NOERRORFLG (RETURN NIL))
             (T (\ILLEGAL.ARG FACE])

(\FONTFILENAME
  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)               (* ; "Edited  5-Mar-93 16:10 by rmk:")

    (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.  New name is of the form %"familysize-face-Ccharset.ext%", e.g., MODERN12-MRR-C357.WD")

    (* ;; "**bvm 10/5/89 Slight change: partition fonts into subdirectories by charset, e.g., all Charset zero fonts are in subdirectory C0>.  This significantly speeds up any font operation that requires any local directory work (e.g., NFS servers on both Sun and D machine), and FONTSAVAILABLE on any device (since it doesn't have to wade thru all those charsets).  This behavior is conditioned on the value of *USEOLDFONTDIRECTORIES*")

    (SETQ FACE (\FONTFACE FACE))                         (* ; "Validate face")
    (LET* ([SIZEPATT (COND
                        ((EQ SIZE '*)
                         SIZE)
                        ((FIXP SIZE)
                         (if (< SIZE 10)
                             then (CONCAT 0 SIZE)
                           else SIZE))
                        (T (\ILLEGAL.ARG SIZE]
           (CSETNAME (COND
                        ((OR (NULL CHARSET)
                             (EQ CHARSET 0))                 (* ; "Charset defaults to zero.")
                         "0")
                        ((FIXP CHARSET)
                         (LET ((*PRINT-BASE* 8)
                               (*PRINT-RADIX* NIL))          (* ; "Longhand for (cl:write-to-string charset :radix nil :base 8), which is twice as slow, due to lousy keyword handling")
                              (\PRINDATUM.TO.STRING CHARSET)))
                        (T                                   (* ; 
                                                           "Somebody made the string already?")
                           CHARSET)))
           [FACESPEC (LIST (CHCON1 (fetch (FONTFACE WEIGHT) of FACE))
                           (CHCON1 (fetch (FONTFACE SLOPE) of FACE))
                           (CHCON1 (fetch (FONTFACE EXPANSION) of FACE]
           (TAIL FACESPEC))
          [if (OR (EQ (CAR TAIL)
                          (CHARCODE *))
                      (EQ (CAR (SETQ TAIL (CDR TAIL)))
                          (CHARCODE *)))
              then                                       (* ; 
            "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower.")
                    (while (EQ (CADR TAIL)
                                   (CHARCODE *)) do (RPLACD TAIL (CDDR TAIL]

          (* ;; "Fortunately, CONCAT ignores packages.")

          (PACKFILENAME.STRING 'NAME (CONCAT (CL:IF *USEOLDFONTDIRECTORIES*
                                                 ""
                                                 (CONCAT (PROGN 
                                                             (* ; 
                   "Lowercase because it's in a directory name, so maybe Unix will find it sooner?")
                                                                "c")
                                                        CSETNAME ">"))
                                            FAMILY SIZEPATT "-" (CONCATCODES FACESPEC)
                                            "-C" CSETNAME)
                 'EXTENSION EXTENSION])

(\FONTFILENAME.OLD
  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)           (* ; "Edited 23-Sep-92 18:22 by jds")

    (* ;; "Returns old style font file names.  They were ambiguous because you could not ask for e.g. FACE (MEDIUM * REGULAR) because it maps to FamilySize-*-Charset, which also matches (BOLD * COMPRESSED), etc.  Keep this function around though for user's who don't rename their files.")
                                                             (* ; 
                     "Returns the name of the file that should contain the information for a font.")
    (SETQ FACE (\FONTFACE FACE))                         (* ; "Force legal canonical face")
    (SETQ FACE (COND
                  ((AND (EQ (CAR FACE)
                            '*)
                        (EQ (CADR FACE)
                            '*))

                   (* ;; "Avoid  adjacent wildcards because DSK gets slower exponentially (can take loooong tiiiiiime).  No need to check compression.")

                   '*)
                  (T FACE)))
    (PACKFILENAME.STRING 'NAME [PROGN 
                                      (* ;; "DISPLAYFONT AC WD and the default case")

                                      (CONCAT (CDR (SASSOC FAMILY *DISPLAY-FONT-NAME-MAP*))
                                             (COND
                                                ((EQ SIZE '*)
                                                 SIZE)
                                                ((FIXP SIZE)
                                                 (COND
                                                    ((< SIZE 10)
                                                     (CONCAT 0 SIZE))
                                                    (T SIZE)))
                                                (T (\ILLEGAL.ARG SIZE)))
                                             [COND
                                                ((EQ FACE '*)
                                                 '*)
                                                (T (SELECTQ (fetch WEIGHT of FACE)
                                                       (BOLD (SELECTQ (fetch SLOPE of FACE)
                                                                 (ITALIC "D")
                                                                 "B"))
                                                       (SELECTQ (fetch SLOPE of FACE)
                                                           (ITALIC "I")
                                                           "R"]
                                             (COND
                                                ((FIXP CHARSET)
                                                 (LET ((*PRINT-BASE* 8))
                                                      (CL:FORMAT NIL "~O" CHARSET)))
                                                (T "000"]
           'EXTENSION EXTENSION])

(\FONTFILENAME.NEW
  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)           (* ; "Edited 30-Mar-87 20:00 by FS")

    (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.")

    (LET (NAME SIZEPATT)
         (SETQ FACE (\FONTFACE FACE))                    (* ; "Validate face")
         [SETQ SIZEPATT (COND
                           ((EQ SIZE '*)
                            SIZE)
                           ((FIXP SIZE)
                            (if (< SIZE 10)
                                then (CONCAT 0 SIZE)
                              else SIZE))
                           (T (\ILLEGAL.ARG SIZE]

         (* ;; "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower.  Nicely, PACK & CONCAT ignore packages.")

         (PACKFILENAME.STRING 'NAME (CONCAT FAMILY SIZEPATT "-"
                                           [COND
                                              ((EQUAL FACE '

         (* * *)
)
                                               '*)
                                              (T (CONCAT (NTHCHAR (fetch (FONTFACE WEIGHT)
                                                                     of FACE)
                                                                1)
                                                        (NTHCHAR (fetch (FONTFACE SLOPE)
                                                                    of FACE)
                                                               1)
                                                        (NTHCHAR (fetch (FONTFACE EXPANSION)
                                                                    of FACE)
                                                               1]
                                           (COND
                                              [(FIXP CHARSET)
                                               (LET ((*PRINT-BASE* 8))
                                                    (CONCAT "-C" (\PRINDATUM.TO.STRING CHARSET]
                                              (CHARSET (CONCAT "-C" CHARSET))
                                              (T "-C0")))
                'EXTENSION EXTENSION])

(\FONTINFOFROMFILENAME
  [LAMBDA (FONTFILE DEVICE)                                  (* ; "Edited 14-Sep-96 10:23 by rmk:")
                                                             (* ; "Edited  5-Oct-89 18:28 by bvm")

    (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.  Rotation is 0 always.  Parses both new & old format files.")

    (LET ((FILENAMELIST (UNPACKFILENAME.STRING FONTFILE))
          CH SIZEBEG SIZEND NAME FAMILY SIZE FACE EXT)
         (SETQ NAME (LISTGET FILENAMELIST 'NAME))            (* ; 
         "find where the name and size are.  MUST check for ch nil below or possible infinite loop")
         (SETQ SIZEBEG (for CH# from 1 when (OR (NUMBERP (SETQ CH (NTHCHAR NAME CH#)))
                                                            (NULL CH)) do (RETURN CH#)))

         (* ;; "Get Family")

         [SETQ FAMILY (MKATOM (U-CASE (SUBSTRING NAME 1 (SUB1 SIZEBEG]

         (* ;; "Get Size")

         [SETQ SIZEND (find CH# from SIZEBEG suchthat (NOT (NUMBERP (NTHCHAR NAME CH#]
         [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
         (if (EQ (NTHCHAR NAME SIZEND)
                     '-)
             then (SETQ SIZEND (ADD1 SIZEND)))

         (* ;; "Get Face")

         (SETQ NAME (U-CASE NAME))                           (* ; 
                                                   "don't need name, but checks for lowercase face")
         [SETQ FACE (LIST (COND
                             ((STRPOS "B" NAME SIZEND NIL T NIL UPPERCASEARRAY)
                              'BOLD)
                             ((STRPOS "L" NAME SIZEND NIL T NIL UPPERCASEARRAY)
                              'LIGHT)
                             (T 'MEDIUM))
                          (COND
                             ((STRPOS "I" NAME SIZEND NIL NIL NIL UPPERCASEARRAY)
                              'ITALIC)
                             (T 'REGULAR))
                          (COND
                             ((STRPOS "E" NAME SIZEND NIL NIL NIL UPPERCASEARRAY)
                              'EXPANDED)
                             ((STRPOS "C-" NAME SIZEND NIL NIL NIL UPPERCASEARRAY)
                              'COMPRESSED)
                             (T 'REGULAR]
         (LIST FAMILY SIZE FACE 0 (COND
                                     ((STREAMP DEVICE)
                                      (IMAGESTREAMTYPE DEVICE))
                                     ((NULL DEVICE)
                                      [SETQ EXT (MKATOM (U-CASE (LISTGET FILENAMELIST 'EXTENSION]
                                      (SELECTQ EXT
                                          (WD 'INTERPRESS)
                                          ((STRIKE AC DISPLAYFONT) 
                                               'DISPLAY)
                                          EXT))
                                     ((LITATOM DEVICE)
                                      (\FONTSYMBOL DEVICE))
                                     (T DEVICE])

(\FONTINFOFROMFILENAME.OLD
  [LAMBDA (FONTFILE DEVICE)                              (* ; "Edited  1-Jan-87 01:29 by FS")

    (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.")

    (PROG ((FILENAMELIST (UNPACKFILENAME FONTFILE))
           SIZEBEG SIZEND NAME FAMILY SIZE)
          (SETQ NAME (LISTGET FILENAMELIST 'NAME))           (* ; 
                                                           "find where the name and size are.")
          (SETQ SIZEBEG (for CH# from 1 when (NUMBERP (NTHCHAR NAME CH#))
                           do (RETURN CH#)))
          [SETQ FAMILY (MKATOM (SUBSTRING NAME 1 (SUB1 SIZEBEG]
          (SETQ SIZEND (for CH# from SIZEBEG when (NOT (NUMBERP (NTHCHAR NAME CH#)))
                          do (RETURN CH#)))
          [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
          (RETURN (LIST FAMILY SIZE (SELECTQ (LISTGET FILENAMELIST 'EXTENSION)
                                        ((DISPLAYFONT AC WD) 
                                             (LIST (COND
                                                      ((STRPOS "-B" NAME SIZEND NIL T)
                                                       'BOLD)
                                                      (T 'MEDIUM))
                                                   (COND
                                                      ((STRPOS "-I" NAME SIZEND NIL)
                                                       'ITALIC)
                                                      (T 'REGULAR))
                                                   'REGULAR))
                                        (LIST (COND
                                                 ((STRPOS "B" NAME SIZEND NIL T)
                                                  'BOLD)
                                                 (T 'MEDIUM))
                                              (COND
                                                 ((STRPOS "I" NAME SIZEND NIL)
                                                  'ITALIC)
                                                 (T 'REGULAR))
                                              'REGULAR))
                        0 DEVICE])

(\GETFONTDESC
  [LAMBDA (SPEC DEVICE NOERRORFLG)                       (* J.Gibbons " 5-Dec-82 16:53")

    (* ;; "Coerces SPEC to a fontdescriptor")
                                                             (* ; 
                                                "\GETFONTDESC HAS MACRO, BUT OLD CALLS STILL EXIST")
    (\COERCEFONTDESC SPEC DEVICE NOERRORFLG])

(\COERCEFONTDESC
  [LAMBDA (SPEC STREAM NOERRORFLG)                       (* ; "Edited 29-Aug-91 12:19 by jds")

    (* ;; "Coerces SPEC to a fontdescriptor appropriate for STREAM.  Go back thru FONTCREATE for various coercions in order to make sure that the cache gets set up")

    (DECLARE (GLOBALVARS DEFAULTFONT))
    (PROG (FONT DEVICE)
          [COND
             ((type? FONTDESCRIPTOR SPEC)
              (SETQ FONT SPEC))
             [(type? FONTCLASS SPEC)
              [SETQ DEVICE (COND
                              ((NULL STREAM)                 (* ; "Default is display")

                               (* ;; "COULDN'T THIS BRANCH BE INTENDED TO MEAN 4DISPLAY, 8DISPLAY, 24DISPLAY?  PEOPLE PROBABLY SHOULDN'T BE CALLING \COERCEFONTDESC WITH STREAM = NIL.")

                               'DISPLAY)
                              ((IMAGESTREAMP STREAM)
                               (IMAGESTREAMTYPE STREAM))
                              ((LITATOM STREAM)
                               (\DEVICESYMBOL STREAM))
                              (STREAM STREAM)
                              (T 
                                 (* ;; "I don't think this case should be allowed.")

                                 'DISPLAY]
              [SETQ FONT (SELECTQ DEVICE
                             (DISPLAY (fetch (FONTCLASS DISPLAYFD) of SPEC))
                             (INTERPRESS (fetch (FONTCLASS INTERPRESSFD) of SPEC))
                             (PRESS (fetch (FONTCLASS PRESSFD) of SPEC))
                             (CDR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of SPEC]
              (RETURN (COND
                         ((type? FONTDESCRIPTOR FONT)

                          (* ;; 
     "We don't always create FD's for devices before they are needed, so do it now and save result")

                          FONT)
                         [(NULL FONT)

                          (* ;; "NIL means create FONT but don't cache.")

                          (COND
                             ((AND (FMEMB DEVICE \DISPLAYSTREAMTYPES)
                                   (SETQ FONT (\COERCEFONTDESC SPEC 'DISPLAY NOERRORFLG))
                                   (SETQ FONT (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG))
                                   )

                              (* ;; 
                            "Coerce existing black & white font to color font, but don't cache.")

                              FONT)
                             [(EQ SPEC DEFAULTFONT)

                              (* ;; "Break cycles with NIL in the defaultfont")

                              (COND
                                 (NOERRORFLG NIL)
                                 ((EQ DEVICE 'DISPLAY)

                                  (* ;; "Function DEFAULTFONT guarantees system integrity")

                                  (DEFAULTFONT 'DISPLAY))
                                 ((EQUAL DEVICE '(HARDCOPY DISPLAY))

                                  (* ;; 
                "MAKE DISPLAY-HARDCOPY FONTS default to the corresponding display font, copied....")

                                  (FONTCOPY (DEFAULTFONT 'DISPLAY)
                                         'DEVICE STREAM 'NOERROR NOERRORFLG))
                                 (T (ERROR (CONCAT DEVICE " component for DEFAULTFONT undefined"]
                             (T (FONTCREATE DEFAULTFONT NIL NIL NIL STREAM NOERRORFLG]
                         ((SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM NOERRORFLG))

                          (* ;; "Might get NIL if NOERRORFLG")

                          (SETFONTCLASSCOMPONENT SPEC DEVICE FONT]
             ((NULL SPEC)
              (RETURN (\COERCEFONTDESC DEFAULTFONT STREAM NOERRORFLG)))
             ((OR (IMAGESTREAMP SPEC)
                  (type? WINDOW SPEC))
              (SETQ FONT (DSPFONT NIL SPEC)))
             (T 
                (* ;; "If called with NOERRORFLG=T (e.g.  from DSPFONT) we want to suppress invalid arg errors as well as font not found, so we can move on to other possible coercions.")

                (RETURN (FONTCREATE SPEC NIL NIL NIL STREAM NOERRORFLG]

     (* ;; "Here if arg was a fontdescriptor or imagestream")

          (RETURN (COND
                     ((NULL STREAM)

                      (* ;; 
                    "NIL device doesn't default to display if a fully-specified font was found")

                      FONT)
                     ([OR (EQ STREAM (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT))
                          (AND (type? STREAM STREAM)
                               (EQ (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM
                                                                                         IMAGEOPS)
                                                                                of STREAM))
                                   (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT]
                      FONT)
                     (T 
                        (* ;; "Here if doesn't match or if DEVICE is not explicitly a stream.")

                        (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG])

(\LOOKUPFONT
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)             (* ; "Edited 28-Jul-88 17:05 by rmk:")
                                                             (* ; "Edited 28-Jul-88 17:04 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")
                                                             (* ; "Edited 28-Jul-88 14:02 by rmk:")
                                                             (* ; "Edited 28-Jul-88 13:54 by rmk:")
                                                             (* ; "Edited 26-Feb-87 00:20 by FS")

    (* ;; "looks up a font in the internal cache.  SASSOC for listp FACE")

    (DECLARE (GLOBALVARS \FONTSINCORE))

    (* ;; "Someone had better have already made FACE canonical")

    (LET [(X (CDR (FASSOC ROTATION (CDR (SASSOC FACE (CDR (FASSOC SIZE (CDR (OR (FASSOC FAMILY 
                                                                                       \FONTSINCORE)
                                                                                (\FONT.SYMBOLASSOC
                                                                                 FAMILY \FONTSINCORE]
         (CDR (OR (FASSOC DEVICE X)
                  (\FONT.SYMBOLASSOC DEVICE X])

(\LOOKUPFONTSINCORE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)                 (* ; "Edited 25-Apr-93 13:07 by rmk:")
                                                             (* rrb "25-Sep-84 12:10")

(* ;;; "returns a list of the fonts that are available in core.  * is used to match anything.")

    (DECLARE (GLOBALVARS \FONTSINCORE))
    (for FAMBUCKET in \FONTSINCORE when (OR (EQ FAMILY '*)
                                                        (EQ FAMILY (CAR FAMBUCKET)))
       join (for SIZEBUCKET in (CDR FAMBUCKET) when (OR (EQ SIZE '*)
                                                                        (EQ SIZE (CAR SIZEBUCKET)))
                   join (for FACEBUCKET in (CDR SIZEBUCKET)
                               when (OR (EQ FACE '*)
                                            (EQUAL FACE (CAR FACEBUCKET)))
                               join (for ROTBUCKET in (CDR FACEBUCKET)
                                           when (OR (EQ ROTATION '*)
                                                        (EQ ROTATION (CAR ROTBUCKET)))
                                           join (for DEVBUCKET in (CDR ROTBUCKET)
                                                       when (AND (OR (EQ DEVICE '*)
                                                                         (EQ DEVICE (CAR DEVBUCKET)))
                                                                     (TYPE? FONTDESCRIPTOR
                                                                            (CDR DEVBUCKET)))
                                                       collect (LIST (CAR FAMBUCKET)
                                                                         (CAR SIZEBUCKET)
                                                                         (CAR FACEBUCKET)
                                                                         (CAR ROTBUCKET)
                                                                         (CAR DEVBUCKET])

(\READDISPLAYFONTFILE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)         (* ; "Edited  8-Oct-96 10:17 by rmk:")
                                                             (* ; 
                                                           "Edited 30-Sep-96 12:03 by kaplan")
                                                             (* ; "Edited  2-Jan-87 17:55 by FS")

    (* ;; "Look for new filename convention, then old file name convention, with extensions.   If CACHEDISPLAYFONTS, this keeps a cache of what was read, on the canonical filename's property list, so that NSDISPLAYSIZES and SMALLSCREEN size coercions can be done and undone without always going out to the directories.")

    (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES CACHEDISPLAYFONTS))
    (BIND FONTFILE CSINFO STRM
       FIRST 

             (* ;; "Cache is indexed by canonical font file name, without the extension fields.")

             (CL:WHEN 
                 [AND CACHEDISPLAYFONTS
                      (FIND EXT INSIDE DISPLAYFONTEXTENSIONS
                         SUCHTHAT (SETQ CSINFO
                                       (GETP (L-CASE (FILENAMEFIELD (IF (FMEMB EXT 
                                                                                *OLD-FONT-EXTENSIONS*
                                                                                   )
                                                                        THEN (\FONTFILENAME.OLD
                                                                                  FAMILY SIZE FACE 
                                                                                  EXT CHARSET)
                                                                      ELSE (\FONTFILENAME
                                                                                FAMILY SIZE FACE EXT
                                                                                CHARSET))
                                                            'NAME))
                                             'CACHEDCHARSET]
                 (RETURN (AND (NEQ CSINFO T)
                              (COPYALL CSINFO)))) FOR EXT INSIDE DISPLAYFONTEXTENSIONS
       WHEN (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET 
                                      DISPLAYFONTDIRECTORIES (LIST EXT)))
       DO 

             (* ;; 
          "Cache is indexed by canonical font file name, without the directory or extension fields")

             (SETQ STRM (OPENSTREAM FONTFILE 'INPUT))
             (RESETLST
                 [SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T)
                                  (STRIKE (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                                                               STRM))
                                          (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE))
                                  (AC 
                                      (* ;; "CLOSEF is guaranteed inside \READACFONTFILE, against the possibility that we have to copy to make randaccessp")

                                      (\READACFONTFILE STRM FAMILY SIZE FACE))
                                  (PROG1 (CLOSEF STRM)       (* ; 
"This would get done by RESETSAVE if AC's were read sequentially and we could factor the RESETSAVE")
                                      (SHOULDNT))])
             (CL:WHEN CACHEDISPLAYFONTS
                 (PUTPROP (L-CASE (FILENAMEFIELD FONTFILE 'NAME))
                        'CACHEDCHARSET CSINFO)
                 (SETQ CSINFO (COPYALL CSINFO))) 

             (* ;; "If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also be nice to tell the user that he has a bogus file.")

             (RETURN CSINFO)
       FINALLY 

             (* ;; "Didn't find the file, cache T to suppress future lookups")

             (CL:WHEN CACHEDISPLAYFONTS
                 (PUTPROP (L-CASE (FILENAMEFIELD (IF (FMEMB (CAR (MKLIST DISPLAYFONTEXTENSIONS))
                                                                *OLD-FONT-EXTENSIONS*)
                                                     THEN (\FONTFILENAME.OLD
                                                               FAMILY SIZE FACE (CAR (MKLIST 
                                                                                DISPLAYFONTEXTENSIONS
                                                                                            ))
                                                               CHARSET)
                                                   ELSE (\FONTFILENAME FAMILY SIZE FACE
                                                                   (CAR (MKLIST DISPLAYFONTEXTENSIONS
                                                                               ))
                                                                   CHARSET))
                                         'NAME))
                        'CACHEDCHARSET T))])
)



(* ;; 
"\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories.  That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places.  "
)


(ADDTOVAR *OLD-FONT-EXTENSIONS* STRIKE)

(RPAQ? *USEOLDFONTDIRECTORIES* NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)
)



(* ;; 
"Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)"
)




(* ;; 
"Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)"
)


(RPAQ? CACHEDISPLAYFONTS T)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS CACHEDISPLAYFONTS)
)



(* ; "STRIKE format file support")

(DEFINEQ

(\READSTRIKEFONTFILE
  [LAMBDA (STRM FAMILY SIZE FACE)                        (* ; "Edited  4-Dec-92 12:11 by jds")
                                                             (* ; 
                             "STRM has already been determined to be a vanilla strike-format file.")
                                                             (* ; "returns a charsetinfo")
    (COND
       ((NEQ 2 (GETFILEPTR STRM))
        (SETFILEPTR STRM 2)))
    (PROG (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
          (SETQ CSINFO (create CHARSETINFO))
          (SETQ FIRSTCHAR (\WIN STRM))                       (* ; "minimum ascii code")
          (SETQ LASTCHAR (\WIN STRM))                        (* ; "maximum ascii code")
          (\WIN STRM)                                        (* ; 
                                                           "MaxWidth which isn't used by anyone.")
          (\WIN STRM)                                        (* ; 
                                                           "number of words in this StrikeBody")
          (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM))
                                                             (* ; 
                                                           "ascent in scan lines (=FBBdy+FBBoy)")
          (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM))
                                                             (* ; "descent in scan-lines (=FBBoy)")
          (\WIN STRM)                                        (* ; 
                                                  "offset in bits (<0 for kerning, else 0, =FBBox)")
          (SETQ RW (\WIN STRM))                              (* ; "raster width of bitmap")
                                                             (* ; "height of bitmap")

     (* ;; "JDS 12/4/92:  Apparently, these fields can be signed values, if all chars, e.g., ride above the base line.")

          (SETQ HEIGHT (IPLUS (SIGNED (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                                     16)
                              (SIGNED (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)
                                     16)))
          (SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
                              HEIGHT))
          (\BINS STRM (fetch BITMAPBASE of BITMAP)
                 0
                 (UNFOLD (ITIMES RW HEIGHT)
                        BYTESPERWORD))                       (* ; "read bits into bitmap")
          (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)
          (SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR)
                                 3))                         (* (SETQ OFFSETS (ARRAY
                                                           (IPLUS \MAXCHAR 3)
                                                           (QUOTE SMALLPOSP) 0 0)))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
                                                             (* ; "initialise the offsets to 0")
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0))
                                                             (* (AIN OFFSETS FIRSTCHAR NUMBCODES 
                                                           STRM))
          (for I from FIRSTCHAR as J from 1 to NUMBCODES
             do (\FSETOFFSET OFFSETS I (\WIN STRM)))
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0))
                                                             (* (replace WIDTHS of
                                                           (CHARSETINFO CSINFO) with
                                                           (ARRAY (IPLUS \MAXCHAR 3)
                                                           (QUOTE SMALLPOSP) 0 0)))
          (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
          (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO
                                                                                    WIDTHS)
                                                                           of CSINFO))
          (RETURN CSINFO])

(\SFMAKEBOLD
  [LAMBDA (CSINFO)                                       (* gbn "25-Jul-85 04:52")
    (PROG* ((OLDCHARBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
            (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
            (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
            (HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                           (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
            NEWCHARBITMAP OFFSET UNKNOWNOFFSET UNKNOWNWIDTH)
           (SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP)
                                      (fetch BITMAPHEIGHT of OLDCHARBITMAP)))
           (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXCHAR)))
           (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXCHAR)))
           [for I from 0 to \MAXCHAR
              do (COND
                        ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                             UNKNOWNOFFSET)                  (* ; 
             "if this is the magic charcode with the slug image (charcode 256) then leave it alone")
                         NIL)
                        (T                                   (* ; 
                                                          "overlap two blts to produce bold effect")
                           (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP OFFSET 0 (\FGETWIDTH WIDTHS I
                                                                                        )
                                  HEIGHT
                                  'INPUT
                                  'REPLACE)
                           (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP (ADD1 OFFSET)
                                  0
                                  (SUB1 (\FGETWIDTH WIDTHS I))
                                  HEIGHT
                                  'INPUT
                                  'PAINT]                    (* ; 
                                                          "fill in the slug for the magic charcode")
           (BITBLT OLDCHARBITMAP UNKNOWNOFFSET 0 NEWCHARBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
                  'INPUT
                  'REPLACE)
           (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWCHARBITMAP])

(\SFMAKEITALIC
  [LAMBDA (CSINFO)                                       (* gbn "18-Sep-85 17:57")
    (PROG ((WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
           (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
           (ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
           (DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
           (OLDBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
           HEIGHT OFFSET NEWBITMAP WIDTH UNKNOWNOFFSET UNKNOWNWIDTH N M R XN XX YN YX)
          (SETQ HEIGHT (IPLUS ASCENT DESCENT))
          (SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP)
                                 (fetch BITMAPHEIGHT of OLDBITMAP)))
          (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR)))
          (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR)))
          (SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3)
                                        4)))
          (SETQ M (IQUOTIENT (IPLUS ASCENT 3)
                         4))
          [for I from 0 to \MAXTHINCHAR
             do (COND
                       ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                            UNKNOWNOFFSET)                   (* ; 
             "if this is the magic charcode with the slug image (charcode 256) then leave it alone")
                        NIL)
                       (T (SETQ WIDTH (\FGETWIDTH WIDTHS I))
                          (for J from N to M
                             do (SETQ R (IPLUS OFFSET WIDTH))
                                   (SETQ XN (IMIN R (IMAX (IPLUS OFFSET J)
                                                          0)))
                                   (SETQ XX (IMIN R (IMAX (IPLUS R J)
                                                          0)))
                                   [SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4]
                                   [SETQ YX (IMIN HEIGHT (IPLUS DESCENT (IPLUS (ITIMES J 4)
                                                                               4]
                                   (COND
                                      ((AND (IGREATERP XX XN)
                                            (IGREATERP YX YN))
                                       (BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN (IDIFFERENCE
                                                                                    XX XN)
                                              (IDIFFERENCE YX YN)
                                              'INPUT
                                              'REPLACE]
          (BITBLT OLDBITMAP UNKNOWNOFFSET 0 NEWBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT
                 'INPUT
                 'REPLACE)
          (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWBITMAP])

(\SFMAKEROTATEDFONT
  [LAMBDA (FONTDESC ROTATION)                            (* ; "Edited 30-Mar-87 20:35 by FS")

    (* ;; "takes a fontdecriptor and rotates it.")

    (* ;; "1/5/86 JDS.  Masterscope claims nobody calls this.  Let's find out....")

    (HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields")
                                                             (* (create FONTDESCRIPTOR using 
                                                           FONTDESC (SETQ CHARACTERBITMAP
                                                           (\SFROTATEFONTCHARACTERS
                                                           (fetch (FONTDESCRIPTOR 
                                                           CHARACTERBITMAP) of FONTDESC) 
                                                           ROTATION)) (SETQ ROTATION ROTATION)
                                                           (SETQ \SFOffsets (
                                                           \SFFIXOFFSETSAFTERROTATION FONTDESC 
                                                           ROTATION)) (SETQ FONTCHARSETVECTOR
                                                           (\ALLOCBLOCK (ADD1 \MAXCHARSET) T))))

    (* ;; "If you uncomment out the code above, remove this comment and the NIL below")

    NIL])

(\SFROTATECSINFO
  [LAMBDA (CSINFO ROTATION)                              (* gbn "15-Sep-85 14:38")

    (* ;; "takes a CHARSETINFO and rotates it and produces a rotated equivalent one.")

    (create CHARSETINFO using CSINFO CHARSETBITMAP _ (\SFROTATEFONTCHARACTERS
                                                              (fetch (CHARSETINFO CHARSETBITMAP)
                                                                 of CSINFO)
                                                              ROTATION)
                                  OFFSETS _ (\SFROTATECSINFOOFFSETS CSINFO ROTATION])

(\SFROTATEFONTCHARACTERS
  [LAMBDA (CHARBITMAP ROTATION)                          (* ; "Edited 22-Sep-87 10:38 by Snow")

(* ;;; "rotate a bitmap either 90 or 270 for fonts.")

    (CASE ROTATION
        (0 CHARBITMAP)
        (90 (ROTATE-BITMAP-LEFT CHARBITMAP))
        (180 (ROTATE-BITMAP (ROTATE-BITMAP CHARBITMAP)))
        (270 (ROTATE-BITMAP CHARBITMAP)))])

(\SFFIXOFFSETSAFTERROTATION
  [LAMBDA (FONTDESC ROTATION)                            (* ; "Edited 30-Mar-87 20:35 by FS")

    (* ;; "adjusts offsets in case where rotation turned things around.")

    (HELP "NEED TO UPDATE THIS FN TO NSCHARS & NEW FONT FIELDS")
                                                             (* (COND ((EQ ROTATION 270)
                                                           (PROG ((OFFSETS (fetch
                                                           (FONTDESCRIPTOR \SFOffsets) of 
                                                           FONTDESC)) (WIDTHS
                                                           (fetch (FONTDESCRIPTOR \SFWidths) of 
                                                           FONTDESC)) (BITMAPHEIGHT
                                                           (BITMAPWIDTH (fetch
                                                           (FONTDESCRIPTOR CHARACTERBITMAP) of 
                                                           FONTDESC))) NEWOFFSETS)
                                                           (SETQ NEWOFFSETS (COPYARRAY OFFSETS))
                                                           (for CHARCODE from 0 to \MAXCHAR do
                                                           (SETA NEWOFFSETS CHARCODE
                                                           (IDIFFERENCE BITMAPHEIGHT
                                                           (IPLUS (ELT OFFSETS CHARCODE)
                                                           (ELT WIDTHS CHARCODE)))))
                                                           (* ; 
                                         "may be some problem with dummy character representation.")
                                                           (RETURN NEWOFFSETS)))
                                                           (T (fetch (FONTDESCRIPTOR \SFOffsets)
  of FONTDESC))))

    (* ;; "If you uncomment out the code above, remove this comment and the NIL below")

    NIL])

(\SFROTATECSINFOOFFSETS
  [LAMBDA (CSINFO ROTATION)                              (* gbn "15-Sep-85 14:36")
                                                             (* ; 
                                     "adjusts offsets in case where rotation turned things around.")
    (COND
       ((EQ ROTATION 270)
        (PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
               (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
               (BITMAPHEIGHT (BITMAPWIDTH (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)))
               NEWOFFSETS)
              (SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
              [for CHARCODE from 0 to \MAXCHAR
                 do (\FSETOFFSET NEWOFFSETS CHARCODE (IDIFFERENCE BITMAPHEIGHT
                                                                (IPLUS (\FGETOFFSET OFFSETS CHARCODE)
                                                                       (\FGETWIDTH WIDTHS CHARCODE]
                                                             (* ; 
                                         "may be some problem with dummy character representation.")
              (RETURN NEWOFFSETS)))
       (T (fetch (CHARSETINFO OFFSETS) of CSINFO])

(\SFMAKECOLOR
  [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL)    (* kbr%: " 6-Feb-86 18:17")

    (* ;; "makes a csinfo that has a character bitmap that is colorized.")

    (PROG (CHARACTERBITMAP COLORCSINFO)
          [COND
             ((IMAGESTREAMP BITSPERPIXEL)
              (OR BACKCOLOR (SETQ BACKCOLOR (DSPBACKCOLOR NIL BITSPERPIXEL)))
              (OR FORECOLOR (SETQ FORECOLOR (DSPCOLOR NIL BITSPERPIXEL)))
              (SETQ BITSPERPIXEL (IMAGESTREAMTYPE BITSPERPIXEL]
          [SETQ BITSPERPIXEL (COND
                                ((NUMBERP BITSPERPIXEL)
                                 BITSPERPIXEL)
                                (T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL]
          (SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL))
          (SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL))
          (SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of 
                                                                                             BWCSINFO
                                                       )
                                       BACKCOLOR FORECOLOR BITSPERPIXEL))
          (SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP _ 
                                                          CHARACTERBITMAP))
          (RETURN COLORCSINFO])
)
(DEFINEQ

(WRITESTRIKEFONTFILE
  [LAMBDA (FONT CHARSET FILENAME)                        (* ; "Edited 30-Mar-87 20:25 by FS")

    (* ;; "Write strike FILE using info in FONT, AND CHARSET number.")

    (* ;; "This code only works if original file was STRIKE.  Otherwise, a new CSINFO is dummied up and it is used instead.  So, CSINFO when read in might be different than the one written out.")

    (PROG (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTHS OFFSETS IMWIDTHS MAXWIDTH RASTERWIDTH LENGTH 
                 DUMMYCHAR DUMMYOFFSET DUMMYINDEX WIDTH OFFSET CODE MAXCODE)
          (SETQ MAXCODE 255)                                 (* ; "Max charcode")
          (SETQ DUMMYINDEX 256)                              (* ; "Dummy char marker")
          (COND
             ((NOT (FONTP FONT))
              (LISPERROR "ILLEGAL ARG" FONT)))
          (COND
             ((NULL CHARSET)
              (SETQ CHARSET 0))
             ((NOT (AND (IGEQ CHARSET 0)
                        (ILESSP CHARSET \MAXCHARSET)))
              (LISPERROR "ILLEGAL ARG" CHARSET)))
          (SETQ CSINFO (STRIKECSINFO (\GETCHARSETINFO CHARSET FONT T)))
                                                             (* ; 
                                                           "Guarantee its a STRIKE font CSINFO.")
          (COND
             ((NULL CSINFO)
              (ERROR "Couldn't find charset " CHARSET)))
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
          (SETQ IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))

     (* ;; "Index 256 contains a dummy width; use it's value to determine missing chars")

          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX))
          [SETQ FIRSTCHAR (for I from 0 to MAXCODE
                             thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
                                                  DUMMYOFFSET]
          [SETQ LASTCHAR (for I from MAXCODE to 0 by -1
                            thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
                                                 DUMMYOFFSET]
          (SETQ DUMMYCHAR (ADD1 LASTCHAR))
          [SETQ STREAM (OPENSTREAM FILENAME 'OUTPUT 'NEW '((TYPE BINARY]

     (* ;; "")

     (* ;; "STRIKE Header")

     (* ;; "")

          (\WOUT STREAM 32768)
          (\WOUT STREAM FIRSTCHAR)
          (\WOUT STREAM LASTCHAR)
          (SETQ MAXWIDTH 0)
          [for I from 0 to DUMMYINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH
                                                                              (\FGETWIDTH WIDTHS I]
          (\WOUT STREAM MAXWIDTH)

     (* ;; "")

     (* ;; "STRIKE Body")

     (* ;; "")

     (* ;; "Length of body")

          (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (CHARSETINFO
                                                                                     CHARSETBITMAP)
                                                                            of CSINFO)))
          (SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR)
                              (ITIMES (fetch (FONTDESCRIPTOR \SFHeight) of FONT)
                                     RASTERWIDTH)))
          (\WOUT STREAM LENGTH)

     (* ;; "Ascent, Descent, Xoffset (no longer used) and Rasterwidth.")

          (\WOUT STREAM (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
          (\WOUT STREAM (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
          (\WOUT STREAM 0)                                   (* ; 
                                                  "offset in bits (<0 for kerning, else 0, =FBBox)")
          (\WOUT STREAM RASTERWIDTH)

     (* ;; "Bitmap")

          [\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (CHARSETINFO CHARSETBITMAP)
                                                                  of CSINFO))
                 0
                 (ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                                              (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]

     (* ;; "Offsets")

          (SETQ CODE 0)
          (\WOUT STREAM CODE)
          (for I from FIRSTCHAR to DUMMYCHAR
             do (SETQ OFFSET (\FGETOFFSET OFFSETS I))
                   (SETQ WIDTH (\FGETWIDTH WIDTHS I))
                   [COND
                      ((AND (IEQP OFFSET DUMMYOFFSET)
                            (NOT (IEQP I DUMMYCHAR)))        (* ; "CODE stays the same.")
                       )
                      (T (SETQ CODE (IPLUS CODE WIDTH]
                   (\WOUT STREAM CODE))
          (CLOSEF STREAM])

(STRIKECSINFO
  [LAMBDA (CSINFO)                                       (* ; "Edited 27-Apr-89 13:39 by atm")

    (* ;; "Returns a STRIKE type font descriptor (EQ WIDTHS IMAGEWIDTHS), cause we know how to write those guys out (they read quicker  but display slower).  If (EQ WIDTHS IMAGEWIDTHS), just return original.")

    (PROG (WIDTHS OFFSETS IMWIDTHS OLDBM BMWIDTH BMHEIGHT NEWBM NEWOFFSET NEWWIDTH OLDOFFSET 
                 DUMMYOFFSET NEWOFFSETS)
          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
          (SETQ IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))
          (if (EQ WIDTHS IMWIDTHS)
              then (RETURN CSINFO))
          (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
          (SETQ OLDBM (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))
          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS 256))
          (SETQ BMHEIGHT (BITMAPHEIGHT OLDBM))
          [SETQ BMWIDTH (for I from 0 to \MAXTHINCHAR
                           sum (if (IEQP DUMMYOFFSET (\FGETOFFSET OFFSETS I))
                                       then 0
                                     else (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
                                                    (\FGETWIDTH WIDTHS I]

     (* ;; "")

     (* ;; "Initialize new offsets vector")

     (* ;; "")

          (SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
          (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET NEWOFFSETS I 0))
          (\FSETOFFSET NEWOFFSETS (ADD1 \MAXTHINCHAR)
                 BMWIDTH)

     (* ;; "")

     (* ;; "Adjust bitmap with so width = imagewidth, fill offsets")

     (* ;; "")

          (SETQ NEWBM (BITMAPCREATE BMWIDTH BMHEIGHT 1))
          (SETQ NEWOFFSET 0)
          [for I from 0 to 255
             do (SETQ OLDOFFSET (\FGETOFFSET OFFSETS I))
                   (if (IEQP DUMMYOFFSET OLDOFFSET)
                       then (\FSETOFFSET NEWOFFSETS I BMWIDTH)
                     else (\FSETOFFSET NEWOFFSETS I NEWOFFSET)
                           (SETQ NEWWIDTH (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
                                                (\FGETWIDTH WIDTHS I)))
                           (BITBLT OLDBM OLDOFFSET 0 NEWBM NEWOFFSET 0 (\FGETWIDTH IMWIDTHS I)
                                  BMHEIGHT
                                  'REPLACE)
                           (SETQ NEWOFFSET (IPLUS NEWOFFSET NEWWIDTH]

     (* ;; "")

     (* ;; "Make new CSInfo record withs IMAGEWIDTHS, WIDTHS the same")

     (* ;; "")

          (SETQ WIDTHS (COPYALL WIDTHS))
          [for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I
                                                                  (IMAX (\FGETWIDTH WIDTHS I)
                                                                        (\FGETIMAGEWIDTH IMWIDTHS I]
          (RETURN (create CHARSETINFO
                         WIDTHS _ WIDTHS
                         OFFSETS _ NEWOFFSETS
                         IMAGEWIDTHS _ WIDTHS
                         CHARSETBITMAP _ NEWBM
                         YWIDTHS _ (fetch (CHARSETINFO YWIDTHS) of CSINFO)
                         CHARSETASCENT _ (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
                         CHARSETDESCENT _ (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO])
)

(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
       '((FONTCLASS 0 (BITS . 7))
         (FONTCLASS 2 POINTER)
         (FONTCLASS 4 POINTER)
         (FONTCLASS 6 POINTER)
         (FONTCLASS 8 POINTER)
         (FONTCLASS 10 POINTER))
       '12)

(/DECLAREDATATYPE 'FONTDESCRIPTOR
       '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD 
               SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 2 POINTER)
         (FONTDESCRIPTOR 4 POINTER)
         (FONTDESCRIPTOR 6 POINTER)
         (FONTDESCRIPTOR 8 (BITS . 15))
         (FONTDESCRIPTOR 9 (BITS . 15))
         (FONTDESCRIPTOR 10 (BITS . 15))
         (FONTDESCRIPTOR 11 (BITS . 15))
         (FONTDESCRIPTOR 12 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 13 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 14 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 15 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 16 POINTER)
         (FONTDESCRIPTOR 18 POINTER)
         (FONTDESCRIPTOR 20 POINTER)
         (FONTDESCRIPTOR 22 POINTER)
         (FONTDESCRIPTOR 24 POINTER)
         (FONTDESCRIPTOR 26 (BITS . 7))
         (FONTDESCRIPTOR 27 (BITS . 15))
         (FONTDESCRIPTOR 28 POINTER)
         (FONTDESCRIPTOR 30 POINTER)
         (FONTDESCRIPTOR 32 POINTER))
       '34)

(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)
       '((CHARSETINFO 0 POINTER)
         (CHARSETINFO 2 POINTER)
         (CHARSETINFO 4 POINTER)
         (CHARSETINFO 6 POINTER)
         (CHARSETINFO 8 POINTER)
         (CHARSETINFO 10 (BITS . 15))
         (CHARSETINFO 11 (BITS . 15))
         (CHARSETINFO 12 POINTER))
       '14)
(ADDTOVAR SYSTEMRECLST

(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
                         DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))

(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
                              (FONTFAMILY POINTER)
                              (FONTSIZE POINTER)
                              (FONTFACE POINTER)
                              (\SFAscent WORD)
                              (\SFDescent WORD)
                              (\SFHeight WORD)
                              (ROTATION WORD)
                              (FBBOX SIGNEDWORD)
                              (FBBOY SIGNEDWORD)
                              (FBBDX SIGNEDWORD)
                              (FBBDY SIGNEDWORD)
                              (\SFLKerns POINTER)
                              (\SFRWidths POINTER)
                              (FONTDEVICESPEC POINTER)
                              (OTHERDEVICEFONTPROPS POINTER)
                              (FONTSCALE POINTER)
                              (\SFFACECODE BITS 8)
                              (FONTAVGCHARWIDTH WORD)
                              (FONTIMAGEWIDTHS POINTER)
                              (FONTCHARSETVECTOR POINTER)
                              (FONTEXTRAFIELD2 POINTER)))

(DATATYPE CHARSETINFO (WIDTHS OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD)
                                 (CHARSETDESCENT WORD)
                                 LEFTKERN))
)

(RPAQ? \FONTSINCORE )

(RPAQ? \DEFAULTDEVICEFONTS )

(RPAQ? \UNITWIDTHSVECTOR )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\UNITWIDTHSVECTOR)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ NORUNCODE 255)


(CONSTANTS (NORUNCODE 255))
)
(* "FOLLOWING DEFINITIONS EXPORTED")
(DEFOPTIMIZER FONTPROP (&REST ARGS)
                           (SELECTQ (AND (EQ (CAADR ARGS)
                                             'QUOTE)
                                         (CADADR ARGS))
                               (ASCENT (LIST 'FONTASCENT (CAR ARGS)))
                               (DESCENT (LIST 'FONTDESCENT (CAR ARGS)))
                               (HEIGHT (LIST 'FONTHEIGHT (CAR ARGS)))
                               'IGNOREMACRO))

(* "END EXPORTED DEFINITIONS")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE

(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
                         DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))

(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
                              (FONTFAMILY POINTER)
                              (FONTSIZE POINTER)
                              (FONTFACE POINTER)
                              (\SFAscent WORD)
                              (\SFDescent WORD)
                              (\SFHeight WORD)
                              (ROTATION WORD)
                              (FBBOX SIGNEDWORD)
                              (FBBOY SIGNEDWORD)
                              (FBBDX SIGNEDWORD)
                              (FBBDY SIGNEDWORD)
                              (\SFLKerns POINTER)
                              (\SFRWidths POINTER)
                              (FONTDEVICESPEC POINTER)       (* ; 
      "Holds the spec by which the font is known to the printing device, if coercion has been done")
                              (OTHERDEVICEFONTPROPS POINTER) (* ; 
                                               "For individual devices to hang special information")
                              (FONTSCALE POINTER)
                              (\SFFACECODE BITS 8)
                              (FONTAVGCHARWIDTH WORD)        (* ; 
                          "Set in FONTCREATE, used to fix up the linelength when DSPFONT is called")
                              (FONTIMAGEWIDTHS POINTER)      (* ; "This is the image width, as opposed to the advanced width;  initial hack for accents, kerning.  Fields is referenced by FONTCREATE.")
                              (FONTCHARSETVECTOR POINTER)    (* ; "A 256-pointer block, with one pointer per 'character set' --each group of 256 character codes.  Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset.")
                              (FONTEXTRAFIELD2 POINTER))
                             FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR))

(RECORD FONTFACE (WEIGHT SLOPE EXPANSION)
                     [ACCESSFNS ((COLOR (CDDDR DATUM)
                                        (RPLACD (CDDR DATUM)
                                               NEWVALUE))
                                 (BACKCOLOR [COND
                                               ((CDDDR DATUM)
                                                (CAR (CDDDR DATUM]
                                        (PROGN [COND
                                                  ((NULL (CDDDR DATUM))
                                                   (RPLACD (CDDR DATUM)
                                                          (LIST NIL NIL]
                                               (RPLACA (CDDDR DATUM)
                                                      NEWVALUE)))
                                 (FORECOLOR [COND
                                               ((CDDDR DATUM)
                                                (CADR (CDDDR DATUM]
                                        (PROGN [COND
                                                  ((NULL (CDDDR DATUM))
                                                   (RPLACD (CDDR DATUM)
                                                          (LIST NIL NIL]
                                               (RPLACA (CDR (CDDDR DATUM))
                                                      NEWVALUE]
                     WEIGHT _ 'MEDIUM SLOPE _ 'REGULAR EXPANSION _ 'REGULAR (TYPE? LISTP))

(DATATYPE CHARSETINFO (WIDTHS                            (* ; "The advance-width of each character, an array indexed by charcode.  Usually the same as the imagewidth, but can differ for accents, kerns kerns.  This is what should be used for stringwidth calculations.")
                                 OFFSETS                     (* ; 
                            "Offset of each character into the image bitmap;  X value of left edge")
                                 IMAGEWIDTHS                 (* ; 
                         "imagewidths is not automagically allocated since it is not always needed")
                                 CHARSETBITMAP               (* ; 
                                       "Bitmap containing the character images, indexed by OFFSETS")
                                 YWIDTHS
                                 (CHARSETASCENT WORD)        (* ; 
                                                    "Max ascent for all characters in this CHARSET")
                                 (CHARSETDESCENT WORD)       (* ; 
                                                   "Max descent for all characters in this CHARSET")
                                 LEFTKERN)
                          WIDTHS _ (\CREATECSINFOELEMENT)
                          OFFSETS _ (\CREATECSINFOELEMENT))
)

(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
       '((FONTCLASS 0 (BITS . 7))
         (FONTCLASS 2 POINTER)
         (FONTCLASS 4 POINTER)
         (FONTCLASS 6 POINTER)
         (FONTCLASS 8 POINTER)
         (FONTCLASS 10 POINTER))
       '12)

(/DECLAREDATATYPE 'FONTDESCRIPTOR
       '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD 
               SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 2 POINTER)
         (FONTDESCRIPTOR 4 POINTER)
         (FONTDESCRIPTOR 6 POINTER)
         (FONTDESCRIPTOR 8 (BITS . 15))
         (FONTDESCRIPTOR 9 (BITS . 15))
         (FONTDESCRIPTOR 10 (BITS . 15))
         (FONTDESCRIPTOR 11 (BITS . 15))
         (FONTDESCRIPTOR 12 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 13 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 14 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 15 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 16 POINTER)
         (FONTDESCRIPTOR 18 POINTER)
         (FONTDESCRIPTOR 20 POINTER)
         (FONTDESCRIPTOR 22 POINTER)
         (FONTDESCRIPTOR 24 POINTER)
         (FONTDESCRIPTOR 26 (BITS . 7))
         (FONTDESCRIPTOR 27 (BITS . 15))
         (FONTDESCRIPTOR 28 POINTER)
         (FONTDESCRIPTOR 30 POINTER)
         (FONTDESCRIPTOR 32 POINTER))
       '34)

(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER)
       '((CHARSETINFO 0 POINTER)
         (CHARSETINFO 2 POINTER)
         (CHARSETINFO 4 POINTER)
         (CHARSETINFO 6 POINTER)
         (CHARSETINFO 8 POINTER)
         (CHARSETINFO 10 (BITS . 15))
         (CHARSETINFO 11 (BITS . 15))
         (CHARSETINFO 12 POINTER))
       '14)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS FONTASCENT  MACRO
   ((FONTSPEC)
    (ffetch \SFAscent of (\GETFONTDESC FONTSPEC))))

(PUTPROPS FONTDESCENT  MACRO
   ((FONTSPEC)
    (ffetch \SFDescent of (\GETFONTDESC FONTSPEC))))

(PUTPROPS FONTHEIGHT  MACRO
   ((FONTSPEC)
    (ffetch \SFHeight of (\GETFONTDESC FONTSPEC))))

(PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE)
                                      (\GETBASE OFFSETSBLOCK CHAR8CODE)))

(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET)
                                      (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET)))

(PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE)
                                     (\GETBASE WIDTHSBLOCK CHAR8CODE)))

(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
                                     (\PUTBASE WIDTHSBLOCK INDEX WIDTH)))

(PUTPROPS \FGETCHARWIDTH  MACRO
   (OPENLAMBDA (FONTDESC CHARCODE)
     (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                FONTDESC))
            (\CHAR8CODE CHARCODE))))

(PUTPROPS \FSETCHARWIDTH  MACRO
   (OPENLAMBDA (FONTDESC CHARCODE WIDTH)
     (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                FONTDESC))
            (\CHAR8CODE CHARCODE)
            WIDTH)))

(PUTPROPS \FGETIMAGEWIDTH  MACRO
   ((IMAGEWIDTHSBLOCK CHAR8CODE)
    (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE)))

(PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
                                          (\PUTBASE WIDTHSBLOCK INDEX WIDTH)))

(PUTPROPS \GETCHARSETINFO  MACRO
   ((CHARSET FONTDESC NOSLUG?)

    (* ;; "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC.  If NIL, then creates the required charset.")

    (* ;; 
  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")

    (OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC)
               (UNFOLD CHARSET 2))
        (\CREATECHARSET CHARSET FONTDESC NOSLUG?))))

(PUTPROPS \CREATECSINFOELEMENT  MACRO
   (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3)
                            WORDSPERCELL))))

(PUTPROPS \CREATEFONTCHARSETVECTOR  MACRO
   (NIL                                                      (* ; 
                                                  "Allocates a block for the character set records")
        (\ALLOCBLOCK (ADD1 \MAXCHARSET)
               T)))
)

(DEFMACRO \CREATEKERNELEMENT ()
   `(CL:MAKE-ARRAY (IPLUS \MAXTHINCHAR 3)
           :ELEMENT-TYPE
           '(SIGNED-BYTE 16)
           :INITIAL-ELEMENT 0))

(DEFMACRO \FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE)
   `(CL:SETF (CL:AREF ,LEFTKERNBLOCK ,INDEX)
           ,KERNVALUE))

(DEFMACRO \FGETLEFTKERN (LEFTKERNBLOCK CHAR8CODE)
   `(CL:AREF ,LEFTKERNBLOCK ,CHAR8CODE))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAXNSCHAR 65535)


(CONSTANTS (\MAXNSCHAR 65535))
)

(* "END EXPORTED DEFINITIONS")

)



(* ; "NS Character specific code")

(DEFINEQ

(\CREATECHARSET
  [LAMBDA (CHARSET FONT NOSLUG?)                         (* ; "Edited  8-May-93 23:42 by rmk:")
                                                             (* ; "Edited  4-Dec-92 11:43 by jds")

    (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR")
                                                             (* ; 
  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")
    (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES))
    (AND (IGREATERP CHARSET \MAXCHARSET)
         (\ILLEGAL.ARG CHARSET))
    (PROG [CSINFO (CREATEFN (COND
                               ((FMEMB (FONTPROP FONT 'DEVICE)
                                       \DISPLAYSTREAMTYPES)
                                (FUNCTION \CREATECHARSET.DISPLAY))
                               (T (CADR (ASSOC 'CREATECHARSET (CDR (ASSOC (FONTPROP FONT
                                                                                 'DEVICE)
                                                                          IMAGESTREAMTYPES]

     (* ;; "Create a descriptor of info for that charset, and use it to fill things in.")

          (COND
             ([NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC)
                                                       (LIST CHARSET FONT NOSLUG?]
                                                             (* ; 
                                               "the create method returned NIL--NOSLUG? must be T.")
              (RETURN NIL)))
          (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT)
                                                            (SIGNED (fetch CHARSETASCENT
                                                                       of CSINFO)
                                                                   16)))
          (replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT)
                                                             (SIGNED (ffetch CHARSETDESCENT
                                                                        of CSINFO)
                                                                    16)))
          (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent of FONT)
                                                             (ffetch \SFDescent of FONT)))
                                                             (* ; 
                              "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")
          (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
                         CHARSET CSINFO])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS 
       CHARSETERRORFLG)
)

(RPAQ? DISPLAYFONTCOERCIONS NIL)

(RPAQ? MISSINGCHARSETDISPLAYFONTCOERCIONS
       '(((GACHA)
          (TERMINAL))
         ((MODERN)
          (CLASSIC))
         ((TIMESROMAN)
          (CLASSIC))
         ((HELVETICA)
          (MODERN))
         ((TERMINAL 6)
          (MODERN 6))
         ((TERMINAL 8)
          (MODERN 8))
         ((TERMINAL 10)
          (MODERN 10))
         ((TERMINAL 12)
          (MODERN 12))))

(RPAQ? MISSINGDISPLAYFONTCOERCIONS '(((GACHA)
                                          (TERMINAL))
                                         ((MODERN)
                                          (CLASSIC))
                                         ((TIMESROMAN)
                                          (CLASSIC))
                                         ((HELVETICA)
                                          (MODERN))))

(RPAQ? CHARSETERRORFLG NIL)

(RPAQ? \DEFAULTCHARSET 0)
(DEFINEQ

(\FONTRESETCHARWIDTHS
  [LAMBDA (CSINFO FIRSTCHAR LASTCHAR)                    (* AJB " 6-Dec-85 14:42")
                                                             (* ; 
                                                     "sets the widths array from the offsets array")
    (PROG ((mincharcode FIRSTCHAR)
           (maxcharcode LASTCHAR)
           (offsets (fetch (CHARSETINFO OFFSETS) of CSINFO))
           (widths (fetch (CHARSETINFO WIDTHS) of CSINFO))
           left right charoffset dummycharoffset dummycharwidth)
          (SETQ dummycharoffset (\FGETOFFSET offsets (ADD1 maxcharcode)))
          (SETQ dummycharwidth (IDIFFERENCE (\FGETOFFSET offsets (IPLUS maxcharcode 2))
                                      dummycharoffset))
          [for charcode from 0 to \MAXCHAR
             do (COND
                       ((OR (ILESSP charcode mincharcode)
                            (IGREATERP charcode maxcharcode))
                        (\FSETOFFSET offsets charcode dummycharoffset)
                        (\FSETWIDTH widths charcode dummycharwidth))
                       (T (SETQ left (\FGETWIDTH offsets charcode))
                          (SETQ right (\FGETWIDTH offsets (ADD1 charcode)))
                          (COND
                             ((EQ left right)
                              (\FSETOFFSET offsets charcode dummycharoffset)
                              (\FSETWIDTH widths charcode dummycharwidth))
                             (T (\FSETWIDTH widths charcode (IDIFFERENCE right left]
          (\FSETWIDTH widths (ADD1 \MAXCHAR)
                 dummycharwidth)
          (\FSETOFFSET offsets (ADD1 \MAXCHAR)
                 dummycharoffset])
)
(DECLARE%: DONTEVAL@LOAD 

(RPAQ? DISPLAYFONTEXTENSIONS 'DISPLAYFONT)

(RPAQ? DISPLAYFONTDIRECTORIES '({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ 
                                          {dsk}/usr/local/lde/fonts/display/publishing/))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \FGETCHARIMAGEWIDTH  MACRO
   (OPENLAMBDA (FONT CHARCODE)
     (\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE)
                                                                     FONT))
            (\CHAR8CODE CHARCODE))))

(PROGN (PUTPROPS \GETFONTDESC DMACRO [X (COND
                                                   ((CDR X)
                                                    (CONS '\COERCEFONTDESC X))
                                                   (T `(\DTEST ,(CAR X)
                                                              'FONTDESCRIPTOR])
       (PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC)))

(PUTPROPS \SETCHARSETINFO  MACRO
   ((CHARSETVECTOR CHARSET CSINFO)
    (\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2)
           CSINFO)))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)

(PUTPROPS FONT FILETYPE :FAKE-COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FONTCOPY)
)
(PUTPROPS FONT COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 1992 1993 1994 1999))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (8608 18127 (CHARWIDTH 8618 . 9403) (CHARWIDTHY 9405 . 10775) (STRINGWIDTH 10777 . 11870
) (\CHARWIDTH.DISPLAY 11872 . 12285) (\STRINGWIDTH.DISPLAY 12287 . 12711) (\STRINGWIDTH.GENERIC 12713
 . 18125)) (18128 24510 (DEFAULTFONT 18138 . 19971) (FONTCLASS 19973 . 22135) (FONTCLASSUNPARSE 22137
 . 23036) (FONTCLASSCOMPONENT 23038 . 23547) (SETFONTCLASSCOMPONENT 23549 . 24508)) (25184 37916 (
FONTCREATE 25194 . 34461) (\FONT.SYMBOLMEMB 34463 . 34693) (\FONT.SYMBOLASSOC 34695 . 35853) (
\FONT.COMPARESYMBOL 35855 . 37914)) (37955 42579 (FONTASCENT 37965 . 38133) (FONTDESCENT 38135 . 38404
) (FONTHEIGHT 38406 . 38592) (FONTPROP 38594 . 42037) (\AVGCHARWIDTH 42039 . 42577)) (42626 55265 (
GETCHARBITMAP 42636 . 45526) (PUTCHARBITMAP 45528 . 53585) (MOVECHARBITMAP 53587 . 55263)) (55266 
140192 (FONTCOPY 55276 . 60584) (FONTSAVAILABLE 60586 . 65791) (FONTFILEFORMAT 65793 . 67417) (FONTP 
67419 . 67718) (FONTUNPARSE 67720 . 70284) (SETFONTDESCRIPTOR 70286 . 71995) (CHARCODEP 71997 . 72358)
 (EDITCHAR 72360 . 72789) (\STREAMCHARWIDTH 72791 . 76955) (\UNITWIDTHSVECTOR 76957 . 77320) (
\CREATEDISPLAYFONT 77322 . 78075) (\CREATECHARSET.DISPLAY 78077 . 80993) (\CREATE-REAL-CHARSET.DISPLAY
 80995 . 88286) (\BUILDSLUGCSINFO 88288 . 89731) (\SEARCHDISPLAYFONTFILES 89733 . 91666) (
\SEARCHFONTFILES 91668 . 94979) (\FINDFONTFILE 94981 . 96172) (\FONTSYMBOL 96174 . 96824) (
\DEVICESYMBOL 96826 . 97695) (\FONTFACE 97697 . 104887) (\FONTFACE.COLOR 104889 . 111809) (
\FONTFILENAME 111811 . 115226) (\FONTFILENAME.OLD 115228 . 118177) (\FONTFILENAME.NEW 118179 . 120436)
 (\FONTINFOFROMFILENAME 120438 . 123552) (\FONTINFOFROMFILENAME.OLD 123554 . 125831) (\GETFONTDESC 
125833 . 126224) (\COERCEFONTDESC 126226 . 131611) (\LOOKUPFONT 131613 . 132957) (\LOOKUPFONTSINCORE 
132959 . 135032) (\READDISPLAYFONTFILE 135034 . 140190)) (141096 158146 (\READSTRIKEFONTFILE 141106 . 
145634) (\SFMAKEBOLD 145636 . 148032) (\SFMAKEITALIC 148034 . 150937) (\SFMAKEROTATEDFONT 150939 . 
152340) (\SFROTATECSINFO 152342 . 152979) (\SFROTATEFONTCHARACTERS 152981 . 153361) (
\SFFIXOFFSETSAFTERROTATION 153363 . 155502) (\SFROTATECSINFOOFFSETS 155504 . 156773) (\SFMAKECOLOR 
156775 . 158144)) (158147 166458 (WRITESTRIKEFONTFILE 158157 . 162998) (STRIKECSINFO 163000 . 166456))
 (180718 183574 (\CREATECHARSET 180728 . 183572)) (184660 186412 (\FONTRESETCHARWIDTHS 184670 . 186410
)))))
STOP
\ No newline at end of file
diff --git a/sources/FONTPROFILE.LCOM.~1~ b/sources/FONTPROFILE.LCOM.~1~
deleted file mode 100644
index 98ed5170..00000000
Binary files a/sources/FONTPROFILE.LCOM.~1~ and /dev/null differ
diff --git a/sources/FONTPROFILE.LCOM.~2~ b/sources/FONTPROFILE.LCOM.~2~
deleted file mode 100644
index a58f35d2..00000000
Binary files a/sources/FONTPROFILE.LCOM.~2~ and /dev/null differ
diff --git a/sources/FONTPROFILE.~2~ b/sources/FONTPROFILE.~2~
deleted file mode 100644
index 23f0bb6a..00000000
--- a/sources/FONTPROFILE.~2~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "28-Jun-99 22:10:46" {DSK}<project>medley3.5>sources>FONTPROFILE.;2 29960  

      changes to%:  (VARS FONTPROFILECOMS)
                    (ALISTS (FONTDEFS NS)
                           (FONTDEFS BIGGERNS))

      previous date%: " 9-Jul-91 18:38:04" {DSK}<project>medley3.5>sources>FONTPROFILE.;1)


(* ; "
Copyright (c) 1986, 1988, 1990, 1991, 1999 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT FONTPROFILECOMS)

(RPAQQ FONTPROFILECOMS
       (
        (* ;; "FONT")

        (ALISTS (FONTDEFS HUGE BIG MEDIUM STANDARD BIGGER NS BIGGERNS))
        (ADDVARS (CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu))
        [VARS (FONTVARS '(
                          (* ;; "standard size fonts. Assumes only DEFAULTFONT set")

                          (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD))
                                                             (* ; "default  BOLD")
                          (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC))
                          (LITTLEFONT DEFAULTFONT)
                                                             (* ; " should usually be smaller")
                          (TINYFONT LITTLEFONT)
                                                             (* ; "and this one smaller still")
                          (BIGFONT BOLDFONT)
                                                             (* ; "should be bigger still")
                          (TEXTFONT DEFAULTFONT)
                                                             (* ; "default for text")
                          (TEXTBOLDFONT BOLDFONT)
                                                             (* ; "default for bold text")
                          
                          (* ;; "")

                          
                          (* ;; "Fonts for window system, processes")

                          
                          (* ;; "")

                          (MENUFONT DEFAULTFONT T)
                          (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD))
                                                             (* ; "if not supplied")
                          (INTERRUPTMENUFONT DEFAULTFONT T)
                                                             (* ; "used by control-B")
                          (DEFAULTICONFONT MENUFONT)
                                                             (* ; "for shrinking windows")
                          (BACKTRACEFONT TINYFONT T)
                                                             (* ; " for backtrace in debugger")
                          (WINDOWTITLEFONT MENUFONT)
                          ((WINDOWTITLEFONT WINDOWTITLEFONT)
                           NIL)
                                                             (* ; " used for titles of all windows")
                          
                          (* ;; "")

                          
                          (* ;; "Fonts for Exec")

                          
                          (* ;; "")

                          (PROMPTFONT LITTLEFONT)
                                                             (* ; "for printing out prompts")
                          (INPUTFONT BOLDFONT)
                                                             (* ; "for user typein in Exec")
                          (PRINTOUTFONT DEFAULTFONT)
                                                             (* ; " for intermediate typin in Exec")
                          (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT))
                          (VALUEFONT DEFAULTFONT)
                                                             (* ; 
                                                        " for printing out values returned in Exec")
                          
                          (* ;; "")

                          
                          (* ;; "Fonts for prettyprinting")

                          
                          (* ;; "")

                          (COMMENTFONT LITTLEFONT)
                                                             (* ; "for comments ")
                          (PRETTYCOMFONT BOLDFONT)
                                                             (* ; " for words being defined")
                          (CLISPFONT BOLDFONT)
                                                             (* ; " for keywords & CLISP")
                          (SYSTEMFONT DEFAULTFONT)
                                                             (* ; " for %"system%" words(?)")
                          (LAMBDAFONT BIGFONT)
                                                             (* ; "for words being defined")
                          (USERFONT BOLDFONT)
                                                             (* ; " for %"user%" defined words")]
        (P (MOVD? 'NILL 'WINDOWTITLEFONT))
        (FNS FONTSET FONTPROFILE FONTPROFILE.ADDDEVICE)
        (INITVARS (FONTESCAPECHAR (CHARACTER 6))
               (FONTFNS)
               (FONTWORDS))
        [DECLARE%: DONTEVAL@LOAD DOCOPY (P (FONTSET 'STANDARD]
        (GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS)
        (FNS FONTMAPARRAY)
        (INITVARS (\FONTMAPCACHE))
        (P (SETSEPR '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26)
                  1 FILERDTBL))))



(* ;; "FONT")


(ADDTOVAR FONTDEFS
          [HUGE (FONTPROFILE (DEFAULTFONT 1 (MODERN 24)
                                    NIL
                                    (TERMINAL 8))
                       (BOLDFONT 2 (MODERN 24 BRR)
                              NIL
                              (MODERN 8 BRR))
                       (LITTLEFONT 3 (MODERN 18 MRR)
                              NIL
                              (MODERN 8 MIR))
                       (BIGFONT 4 (MODERN 36 BRR)
                              NIL
                              (MODERN 10 BRR))
                       (TEXTFONT 5 (CLASSIC 24)
                              NIL
                              (CLASSIC 10))
                       (TEXTBOLDFONT 7 (CLASSIC 24 BRR)
                              NIL
                              (CLASSIC 10 BRR]
          [BIG (FONTPROFILE (DEFAULTFONT 1 (MODERN 18)
                                   NIL
                                   (TERMINAL 8))
                      (TEXTFONT 5 (CLASSIC 18)
                             NIL
                             (CLASSIC 10))
                      (BOLDFONT 2 (MODERN 18 BRR)
                             NIL
                             (MODERN 8 BRR))
                      (LITTLEFONT 3 (MODERN 12 MRR)
                             NIL
                             (MODERN 8 MIR))
                      (BIGFONT 4 (MODERN 24 BRR)
                             NIL
                             (MODERN 10 BRR))
                      (TEXTBOLDFONT 7 (CLASSIC 18 BRR)
                             NIL
                             (CLASSIC 10 BRR]
          [MEDIUM (FONTPROFILE (DEFAULTFONT 1 (MODERN 14)
                                      NIL
                                      (TERMINAL 8))
                         (BOLDFONT 2 (MODERN 14 BRR)
                                NIL
                                (MODERN 8 BRR))
                         (LITTLEFONT 3 (MODERN 10)
                                NIL
                                (MODERN 8 MIR))
                         (BIGFONT 4 (MODERN 18)
                                NIL
                                (MODERN 10 BRR))
                         (TEXTFONT 5 (CLASSIC 14)
                                NIL
                                (CLASSIC 10))
                         (TEXTBOLDFONT 7 (CLASSIC 14 BRR)
                                NIL
                                (CLASSIC 10 BRR]
          [STANDARD (FONTCHANGEFLG . ALL)
                 (FILELINELENGTH . 102)
                 (FONTPROFILE (DEFAULTFONT 1 (GACHA 10)
                                     (GACHA 8)
                                     (TERMINAL 8))
                        (ITALICFONT 1 (HELVETICA 10 MIR)
                               (GACHA 8 MIR)
                               (MODERN 8 MIR))
                        (BOLDFONT 2 (HELVETICA 10 BRR)
                               (HELVETICA 8 BRR)
                               (MODERN 8 BRR))
                        (LITTLEFONT 3 (HELVETICA 8)
                               (HELVETICA 6 MIR)
                               (MODERN 8 MIR))
                        (TINYFONT 6 (GACHA 8)
                               (GACHA 6)
                               (TERMINAL 6))
                        (BIGFONT 4 (HELVETICA 12 BRR)
                               NIL
                               (MODERN 10 BRR))
                        (MENUFONT 5 (HELVETICA 10))
                        (COMMENTFONT 6 (HELVETICA 10)
                               (HELVETICA 8)
                               (MODERN 8))
                        (TEXTFONT 7 (TIMESROMAN 10)
                               NIL
                               (CLASSIC 10]
          [BIGGER (FONTPROFILE (DEFAULTFONT 1 (GACHA 12)
                                      NIL
                                      (TERMINAL 8))
                         (ITALICFONT 1 (HELVETICA 12 MIR)
                                (GACHA 8 MIR)
                                (MODERN 8 MIR))
                         (BOLDFONT 2 (HELVETICA 12 BRR)
                                (HELVETICA 8 BRR)
                                (MODERN 8 BRR))
                         (LITTLEFONT 3 (HELVETICA 10)
                                (HELVETICA 6 MIR)
                                (MODERN 8 MIR))
                         (TINYFONT 6 (GACHA 10)
                                (GACHA 6)
                                (TERMINAL 6))
                         (BIGFONT 4 (HELVETICA 14 BRR)
                                NIL
                                (MODERN 10 BRR))
                         (MENUFONT 5 (HELVETICA 12))
                         (COMMENTFONT 6 (HELVETICA 12)
                                (HELVETICA 8)
                                (MODERN 8))
                         (TEXTFONT 7 (TIMESROMAN 12)
                                NIL
                                (CLASSIC 10]
          [NS (FONTCHANGEFLG . ALL)
              (FILELINELENGTH . 102)
              (COMMENTLINELENGTH 116 . 126)
              (FIRSTCOL . 60)
              (PRETTYLCOM . 25)
              (FONTESCAPECHAR . %)
              (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 10)
                                  (TERMINAL 8)
                                  (TERMINAL 8))
                     (ITALICFONT 1 (MODERN 10 BIR)
                            (MODERN 8 BIR)
                            (MODERN 8 BIR))
                     (BOLDFONT 2 (MODERN 10 BRR)
                            (MODERN 8 BRR)
                            (MODERN 8 BRR))
                     (LITTLEFONT 3 (MODERN 8)
                            (MODERN 6 MIR)
                            (MODERN 8 MIR))
                     (BIGFONT 4 (MODERN 12 BRR)
                            (MODERN 10 BRR)
                            (MODERN 10 BRR]
          [BIGGERNS (FONTCHANGEFLG . ALL)
                 (FILELINELENGTH . 102)
                 (COMMENTLINELENGTH 116 . 126)
                 (FIRSTCOL . 60)
                 (PRETTYLCOM . 25)
                 (FONTESCAPECHAR . %)
                 (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 12)
                                     (TERMINAL 8)
                                     (TERMINAL 8))
                        (ITALICFONT 1 (MODERN 12 BIR)
                               (MODERN 8 BIR)
                               (MODERN 8 BIR))
                        (BOLDFONT 2 (MODERN 12 BRR)
                               (MODERN 8 BRR)
                               (MODERN 8 BRR))
                        (LITTLEFONT 3 (MODERN 10)
                               (MODERN 6 MIR)
                               (MODERN 8 MIR))
                        (BIGFONT 4 (MODERN 14 BRR)
                               (MODERN 10 BRR)
                               (MODERN 10 BRR])

(ADDTOVAR CACHEDMENUS BreakMenu WindowMenu BackgroundMenu IconWindowMenu)

(RPAQQ FONTVARS
       (
        (* ;; "standard size fonts. Assumes only DEFAULTFONT set")

        (BOLDFONT (FONTCOPY DEFAULTFONT 'FACE 'BOLD))
                                                             (* ; "default  BOLD")
        (ITALICFONT (FONTCOPY DEFAULTFONT 'FACE 'ITALIC))
        (LITTLEFONT DEFAULTFONT)
                                                             (* ; " should usually be smaller")
        (TINYFONT LITTLEFONT)
                                                             (* ; "and this one smaller still")
        (BIGFONT BOLDFONT)
                                                             (* ; "should be bigger still")
        (TEXTFONT DEFAULTFONT)
                                                             (* ; "default for text")
        (TEXTBOLDFONT BOLDFONT)
                                                             (* ; "default for bold text")
        
        (* ;; "")

        
        (* ;; "Fonts for window system, processes")

        
        (* ;; "")

        (MENUFONT DEFAULTFONT T)
        (BOLDMENUFONT (FONTCOPY MENUFONT 'FACE 'BOLD))
                                                             (* ; "if not supplied")
        (INTERRUPTMENUFONT DEFAULTFONT T)
                                                             (* ; "used by control-B")
        (DEFAULTICONFONT MENUFONT)
                                                             (* ; "for shrinking windows")
        (BACKTRACEFONT TINYFONT T)
                                                             (* ; " for backtrace in debugger")
        (WINDOWTITLEFONT MENUFONT)
        ((WINDOWTITLEFONT WINDOWTITLEFONT)
         NIL)
                                                             (* ; " used for titles of all windows")
        
        (* ;; "")

        
        (* ;; "Fonts for Exec")

        
        (* ;; "")

        (PROMPTFONT LITTLEFONT)
                                                             (* ; "for printing out prompts")
        (INPUTFONT BOLDFONT)
                                                             (* ; "for user typein in Exec")
        (PRINTOUTFONT DEFAULTFONT)
                                                             (* ; " for intermediate typin in Exec")
        (TTYINBOLDFONT (CONS DEFAULTFONT BOLDFONT))
        (VALUEFONT DEFAULTFONT)
                                                             (* ; 
                                                        " for printing out values returned in Exec")
        
        (* ;; "")

        
        (* ;; "Fonts for prettyprinting")

        
        (* ;; "")

        (COMMENTFONT LITTLEFONT)
                                                             (* ; "for comments ")
        (PRETTYCOMFONT BOLDFONT)
                                                             (* ; " for words being defined")
        (CLISPFONT BOLDFONT)
                                                             (* ; " for keywords & CLISP")
        (SYSTEMFONT DEFAULTFONT)
                                                             (* ; " for %"system%" words(?)")
        (LAMBDAFONT BIGFONT)
                                                             (* ; "for words being defined")
        (USERFONT BOLDFONT)
                                                             (* ; " for %"user%" defined words")))

(MOVD? 'NILL 'WINDOWTITLEFONT)
(DEFINEQ

(FONTSET
  [LAMBDA (NAME CHANGE-WINDOWS?)                         (* ; "Edited 23-Jun-88 10:46 by jds")
    (COND
       [NAME
        (LET
         [(TEM (FASSOC NAME FONTDEFS))
          (OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY]
         (OR TEM (ERROR NAME "not a defined font configuration"))

         (* ;; "Looks up NAME on FONTSLST and sets apropriate parameters.  entries are added to fontslst by FONTNAME.")

         (for X in FONTVARS when (AND (CL:SYMBOLP (CAR X))
                                                  (NEQ (CAR X)
                                                       '*)
                                                  (NEQ (CAR X)
                                                       (CADR X))) do (SETTOPVAL (CAR X)))
         [MAPC (CDR TEM)
               (FUNCTION (LAMBDA (X)
                           (/SETTOPVAL (CAR X)
                                  (CDR X]
         [PROG (BASICCLASSES)
               (for X in FONTPROFILE
                  do (PROG (SEEN (NAME (CAR X))
                                     (FONTS X))
                           LP  [COND
                                  ((MEMB (CAR FONTS)
                                         SEEN)
                                   (ERROR "Circular font profile specification" X))
                                  (T (push SEEN (CAR FONTS]
                               [SETQ FONTS (CDR (COND
                                                   ((OR (NULL (CADR FONTS))
                                                        (LISTP (CADR FONTS)))
                                                             (*)
                                                             (* ; 
                                   "This skips over the now-defunct NIL or list-of-escape sequence")
                                                    (CDR FONTS))
                                                   (T FONTS]
                               (COND
                                  ((OR (NLISTP FONTS)
                                       (LITATOM (CAR FONTS)))(* ; 
                                                           "Indirect thru another's font spec")
                                   (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS))
                                                               ((NIL DEFAULTFONT) 
                                                             (* ; 
                                                           "Don't let DEFAULTFONT loop thru itself")
                                                                    (AND (NOT (MEMB 'DEFAULTFONT SEEN
                                                                                    ))
                                                                         'DEFAULTFONT))
                                                               (CAR FONTS))
                                                           FONTPROFILE))
                                        (GO LP)))
                                  (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS
                                                                               'DISPLAY]
                                                             (* ; 
                                                           "Now we have a font class datastructure")
                                     ))
                               (AND NAME (/SETTOPVAL NAME FONTS))

                          (* ;; "NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.")

                           ))
               (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY]
         [for X in FONTVARS when (NEQ (CAR X)
                                                  '*)
            do (COND
                      ((LISTP (CAR X))
                       (EVAL (CAR X)))
                      [(CADDR X)
                       (SET (CAR X)
                            (FONTCREATE (OR (GETTOPVAL (CAR X))
                                            (EVAL (CADR X))
                                            DEFAULTFONT)
                                   NIL NIL NIL 'DISPLAY]
                      (T (OR (GETTOPVAL (CAR X))
                             (AND (CADR X)
                                  (SET (CAR X)
                                       (EVAL (CADR X]
         (CL:WHEN CHANGE-WINDOWS?
             (CL:WHEN (NEQ OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY))
                 (for X in (OPENWINDOWS) when (EQ OLDDEFAULT (DSPFONT NIL X))
                    do (DSPFONT DEFAULTFONT X)))
             (DSPFONT WINDOWTITLEFONT WindowTitleDisplayStream)
             (SETQ MaxValueLeftMargin (ITIMES 35 (STRINGWIDTH 'A DEFAULTFONT)))
             (MAPC CACHEDMENUS 'SET)
             [for W in (OPENWINDOWS) do [COND
                                                       [(OR (EQ (WINDOWPROP W 'RESHAPEFN)
                                                                'DONT)
                                                            (WINDOWPROP W 'MAINWINDOW]
                                                       (T 
                                                          (* ;; 
                                 "don't reshape if can't or if this window is attached to another.")

                                                          (SHAPEW W (WINDOWREGION W]
                                                   (COND
                                                      ((AND (NEQ (WINDOWPROP W 'WINDOWENTRYFN)
                                                                 (FUNCTION \TEDIT.PROCIDLEFN))
                                                            (WINDOWPROP W 'REPAINTFN))
                                                       (REDISPLAYW W])

         (* ;; "Set the new font profile name, and return the old one, so he can restore later.")

         (PROG1 FONTNAME (SETQ FONTNAME NAME]
       (T                                                    (* ; 
                                         "He passed in NIL, so return font profile name in effect.")
          FONTNAME])

(FONTPROFILE
  [LAMBDA (PROFILE)                                          (* lmm "10-Sep-86 12:33")
    [PROG (BASICCLASSES)
          (for X in PROFILE
             do (PROG (SEEN (NAME (CAR X))
                            (FONTS X))
                  LP  [COND
                         ((MEMB (CAR FONTS)
                                SEEN)
                          (ERROR "Circular font profile specification" X))
                         (T (push SEEN (CAR FONTS]
                      [SETQ FONTS (CDR (COND
                                          ((OR (NULL (CADR FONTS))
                                               (LISTP (CADR FONTS)))
                                                  (* ; 
                                     "This skips over the now-defunct NIL or list-of-escape sequence")
                                           (CDR FONTS))
                                          (T FONTS]
                      (COND
                         ((OR (NLISTP FONTS)
                              (LITATOM (CAR FONTS)))         (* Indirect thru another's font spec)
                          (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS))
                                                      ((NIL DEFAULTFONT) 
                                                             (* Don't let DEFAULTFONT loop thru 
                                                             itself)
                                                           (AND (NOT (MEMB 'DEFAULTFONT SEEN))
                                                                'DEFAULTFONT))
                                                      (CAR FONTS))
                                                  PROFILE))
                               (GO LP)))
                         (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY]
                                                             (* Now we have a font class 
                                                             datastructure)
                            ))
                      (AND NAME (/SETATOMVAL NAME FONTS))
          
          (* NIL for the class-name means just establish the font-correspondences but 
          don't connect them up with a pretty class name.)

                  ))
          (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY]
    T])

(FONTPROFILE.ADDDEVICE
  [LAMBDA (NEWDEVICE OLDDEVICE)                              (* ; "Edited  3-Mar-93 14:46 by rmk:")

    (* ;; "Fills in all fontprofile specifications so that an entry for NEWDEVICE is present for each fontclass.  Nothing is changed if the entry is already there, otherwise the specification for the class currently provided for OLDDEVICE will be used for NEWDEVICE.")

    (DECLARE (USEDFREE FONTDEFS FONTNAME))
    (SETQ NEWDEVICE (U-CASE NEWDEVICE))
    (SETQ OLDDEVICE (U-CASE OLDDEVICE))
    [FOR FD IN FONTDEFS
       DO (FOR FC OLDSPEC IN (CDR (ASSOC 'FONTPROFILE (CDR FD)))
                 UNLESS (LITATOM (CADR FC))
                 DO (SETQ FC (CDR FC))                   (* ; "Skip over name")
                       (CL:WHEN [SETQ OLDSPEC (SELECTQ OLDDEVICE
                                                  (DISPLAY (CADR FC))
                                                  (INTERPRESS (CADDDR FC))
                                                  (PRESS (CADDR FC))
                                                  (CADR (ASSOC OLDDEVICE (CDDDDR FC]
                           [SETQ FC (OR (CDR FC)
                                        (CDR (RPLACD FC (CONS]
                                                             (* ; 
                                          "Fill in NIL's for missing DISPLAY, PRESS, or INTERPRESS")
                           [SELECTQ NEWDEVICE
                               (DISPLAY (OR (CAR FC)
                                            (RPLACA FC OLDSPEC)))
                               (INTERPRESS (OR (CADDR FC)
                                               (RPLACA [PROGN [SETQ FC (OR (CDR FC)
                                                                           (CDR (RPLACD FC (CONS]
                                                              (OR (CDR FC)
                                                                  (CDR (RPLACD FC (CONS]
                                                      OLDSPEC)))
                               (PRESS (OR (CADDR FC)
                                          (RPLACA [OR (CDR FC)
                                                      (CDR (RPLACD FC (CONS]
                                                 OLDSPEC)))
                               (OR (CADR (ASSOC NEWDEVICE (CDDDR FC)))
                                   (PROGN (PROGN [SETQ FC (OR (CDR FC)
                                                              (CDR (RPLACD FC (CONS]
                                                 [SETQ FC (OR (CDR FC)
                                                              (CDR (RPLACD FC (CONS]
                                                 (PUSH (CDR FC)
                                                        (LIST NEWDEVICE OLDSPEC])]
    (FONTSET FONTNAME])
)

(RPAQ? FONTESCAPECHAR (CHARACTER 6))

(RPAQ? FONTFNS )

(RPAQ? FONTWORDS )
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(FONTSET 'STANDARD)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS FONTPROFILE FONTESCAPECHAR FONTDEFS)
)
(DEFINEQ

(FONTMAPARRAY
  [LAMBDA (FONTCLASSES)                                      (* lmm "28-Sep-86 14:23")
                                                  (* ;; "Makes a font array from a font-mapping list of fontclasses.  The array provides a fast map from font# to font classes/descriptors. This function caches the last array.  If IMAGETYPES is given, then the FD's are pre-computed for the imagetypes it.  Otherwise, the first use of the fontclass for that imagetype would cause the fontcreate to be done.")
    (PROG (FA (MAXFONT 0)
              (MINFONT 100))
          [COND
             ((NULL \FONTMAPCACHE))
             ((OR (NULL FONTCLASSES)
                  (EQUAL FONTCLASSES (CAR \FONTMAPCACHE)))
              (RETURN (CDR \FONTMAPCACHE]
          [for F PRETTYFONT# in FONTCLASSES do (SETQ PRETTYFONT# (fetch (FONTCLASS PRETTYFONT#)
                                                                    of F))
                                               (COND
                                                  ((IGREATERP PRETTYFONT# MAXFONT)
                                                   (SETQ MAXFONT PRETTYFONT#)))
                                               (COND
                                                  ((ILESSP PRETTYFONT# 1)
                                                   (ERROR "Invalid font number" PRETTYFONT# F))
                                                  ((ILESSP PRETTYFONT# MINFONT)
                                                   (SETQ MINFONT PRETTYFONT#]
          (SETQ FA (ARRAY MAXFONT))
          (for F in FONTCLASSES do (SETA FA (fetch (FONTCLASS PRETTYFONT#) of F)
                                         F))
          (for I from 1 to MAXFONT unless (ELT FA I) do (SETA FA I (ELT FA MINFONT)))
          (SETQ \FONTMAPCACHE (CONS (COPY FONTCLASSES)
                                    FA))
          (RETURN FA])
)

(RPAQ? \FONTMAPCACHE )

(SETSEPR '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26)
       1 FILERDTBL)
(PUTPROPS FONTPROFILE COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990 1991 1999))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (16000 27584 (FONTSET 16010 . 22351) (FONTPROFILE 22353 . 24702) (FONTPROFILE.ADDDEVICE 
24704 . 27582)) (27820 29719 (FONTMAPARRAY 27830 . 29717)))))
STOP
\ No newline at end of file
diff --git a/sources/LLFAULT b/sources/LLFAULT
index 07031b64..c5cb6d3d 100644
--- a/sources/LLFAULT
+++ b/sources/LLFAULT
@@ -1 +1 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 2-Jan-93 12:26:58" {DSK}<users>sybalsky>3-BYTE-ATOMS>LLFAULT.;1 550130Q

      changes to%:  (VARS \MAXFILEPAGE)
                    (FNS \MAIKO.FAULTINIT)

      previous date%: " 5-Nov-92 18:39:48" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>LLFAULT.;8|)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT LLFAULTCOMS)

(RPAQQ LLFAULTCOMS
       [(VARS (FAULTTEST T))
        (COMS                                                (* ; 
                                                 "Bootstrap code, run once when an image is booted")
              (FNS \FAULTINIT \D01.FAULTINIT \D01.ASSIGNBUFFERS \MAIKO.FAULTINIT \MAIKO.NEWFAULTINIT
                   \MAIKO.ASSIGNBUFFERS \M-VMEMSAVE \MAIKO.NEWPAGE)
              
              (* ;; "For setting up (and maybe eventually removing?) MAIKO-specific versions of the generic low-levle functions:")

              (FNS \MAIKO.DO.MOVDS)
              (ADDVARS (\MAIKO.MOVDS (TRUE \LOCKEDPAGEP)
                              (\MAIKO.NEWPAGE \NEWPAGE)
                              (\MAIKO.NEWPAGE \DONEWPAGE)
                              (NILL \LOCKPAGES)
                              (NILL \DOLOCKPAGES)
                              (NILL \DOTEMPLOCKPAGES)
                              (NILL \TEMPUNLOCKPAGES)
                              (NILL \UNLOCKPAGES)
                              (NILL \WRITEDIRTYPAGE)
                              (NILL \DIRTYBACKGROUND)
                              (ZERO \COUNTREALPAGES)
                              (NILL \SHOWPAGETABLE)
                              (NILL CHECKPAGEMAP)
                              (EVQ \PAGEFAULT)
                              (EVQ \LOADVMEMPAGE)
                              (NILL \LOADVMEMPAGE)
                              (TRUE \MOVEVMEMFILEPAGE)
                              (TRUE \VALIDADDRESSP)))
              (FNS \DOVE.FAULTINIT \DL.FAULTINIT \DL.NEWFAULTINIT \DL.UNMAPPAGES 
                   \DL.MARK.PAGES.UNAVAILABLE \DL.ASSIGNBUFFERS \CHAIN.UP.RPT))
        (COMS                                                (* ; "Pagefault handler")
              (FNS \FAULTHANDLER \PAGEFAULT \INVALIDADDR \INVALIDVP \FLUSHPAGE \LOADVMEMPAGE 
                   \MOVEREALPAGE \LOOKUPPAGEMAP \VALIDADDRESSP \LOCKEDPAGEP \SELECTREALPAGE 
                   \SPECIALRP \TRANSFERPAGE \UPDATECHAIN))
        (COMS                                                (* ; 
                                                           "Allocating and locking new pages")
              (FNS \NEWPAGE \DONEWPAGE \ASSURE.FPTOVP.PAGE \MAKESPACEFORLOCKEDPAGE \MOVEVMEMFILEPAGE
                   \NEWEPHEMERALPAGE \DONEWEPHEMERALPAGE \LOCKPAGES \DOLOCKPAGES \TEMPLOCKPAGES 
                   \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \UNLOCKPAGES))
        (COMS                                                (* ; "Writing out the vmem")
              (FNS \FLUSHVM \LOGOUT0 \DOFLUSHVM \RELEASEWORKINGSET \WRITEDIRTYPAGE \WRITEDIRTYPAGE1 
                   \COUNTREALPAGES))
        (COMS                                                (* ; "VMEM.PURE.STATE hack")
              (FNS \DOCOMPRESSVMEM VMEM.PURE.STATE))
        (COMS 
              (* ;; "Handling the backing store getting too full--keep running, but if we overflow, we can never \FLUSHVM because there is no place to write some pages")

              (FNS 32MBADDRESSABLE \SET.VMEM.FULL.STATE \SET.LASTVMEMFILEPAGE \DOVMEMFULLINTERRUPT 
                   \FLUSHVMOK?))
        (INITVARS (\UPDATECHAINFREQ 100)
               (\PAGEFAULTCOUNTER 0)
               (\DIRTYPAGECOUNTER 0)
               (\DIRTYPAGEHINT 0)
               (\LASTACCESSEDVMEMPAGE 0)
               (\MAXSHORTSEEK 1000)
               (\MINSHORTSEEK 20)
               (\MAXCLEANPROBES 20)
               (\VMEM.INHIBIT.WRITE)
               (\VMEM.PURE.LIMIT)
               (\VMEM.FULL.STATE)
               (\GUARDVMEMFULL 500)
               (VMEM.COMPRESS.FLG)
               (\DOFAULTINIT 0)
               (\VMEMACCESSFN)
               (\SYSTEMCACHEVARS)
               (\MAXSWAPBUFFERS 1)
               (\EXTENDINGVMEMFILE)
               (\MaxScreenPage 0)
               (\NEWVMEMPAGEADDED))
        (INITVARS (\LASTDIRTYCNT)
               (\LASTDIRTYFOUND)
               (\LASTDIRTYSCANPTR)
               (\DIRTYSEEKMAX 50))
        (COMS                                                (* ; 
                                                         "Errors signaled in the maintenance panel")
              (FNS \MP.ERROR))
        (COMS                                                (* ; 
                          "Debugging code.  Some of this also runs renamed for extra TeleRaid help")
              (FNS \ACTONVMEMFILE \SHOWPAGETABLE CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \PRINTFPTOVP 
                   \PRINTVP))
        (E (RESETSAVE (RADIX 8)))
        (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \ACTONVMEMFILE .VMEM.CONSISTENTP. .LOCKABLERP.)
               (COMS                                         (* ; "Virtual page flags")
                     (CONSTANTS \VMAP.DIRTY \VMAP.CLEAN \VMAP.REF \VMAP.VACANT \VMAP.FLAGS 
                            \VMAP.NOTFLAGS)
                     (RECORDS VMEMFLAGS)
                     (MACROS LOGNOT16))
               (COMS                                         (* ; "RPT constants")
                     (CONSTANTS \RPT.EMPTY \RPT.UNAVAILABLE \PAGETABLESTOPFLG \RPTENTRYLENGTH)
                     (RECORDS RPT RPT1)
                     (MACROS RPFROMRPT RPTFROMRP NPAGESMACRO))
               (COMS                                         (* ; "Virtual to file pagemap")
                     (EXPORT (CONSTANTS \MAXFILEPAGE))
                     (CONSTANTS \EMPTYPMTENTRY)
                     (RECORDS VP)
                     (MACROS .PAGEMAPBASE.))
               (COMS                                         (* ; "FP to VP stuff")
                     (RECORDS FPTOVP)
                     (CONSTANTS \NO.VMEM.PAGE)
                     (MACROS DLRPFROMFP DLFPFROMRP))
               (PROP DOPVAL \TOUCHPAGE TIMES3)
               (COMS                                         (* ; "Locked page table")
                     (MACROS .LOCKEDVPBASE. .LOCKEDVPMASK.))
               (CONSTANTS \MAXDIRTYSCANCOUNT \MINVMEMSPAREPAGES \DLBUFFERPAGES)
               (CONSTANTS 2MBPAGES)
               (GLOBALVARS \UPDATECHAINFREQ \REALPAGETABLE \RPTLAST \RPOFFSET \RPTSIZE 
                      \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP \PAGEFAULTCOUNTER \LASTDIRTYCNT 
                      \LASTDIRTYFOUND \LASTDIRTYSCANPTR \MACHINETYPE \LASTACCESSEDVMEMPAGE 
                      \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYSEEKMAX \DIRTYPAGECOUNTER 
                      \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE 
                      \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT 
                      \FPTOVP \VMEMACCESSFN \SYSTEMCACHEVARS \LASTVMEMFILEPAGE \EXTENDINGVMEMFILE 
                      \MaxScreenPage \NEWVMEMPAGEADDED)
               (GLOBALVARS \#SWAPBUFFERS \#EMUBUFFERS \#DISKBUFFERS \MAXSWAPBUFFERS \EMUSWAPBUFFERS 
                      \EMUBUFFERS \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND)
               (MACROS RWMufMan)
               (CONSTANTS (DOLOCKCHECKS NIL)))
        [COMS 

(* ;;; "MAKEINIT stuff")

              (FNS ADDPME CHECKIFPAGE DUMPINITPAGES MAKEROOMFORPME MAPPAGES READPAGEMAP 
                   READPAGEMAPBLOCK SETUPPAGEMAP)
              (DECLARE%: DONTCOPY (MACROS CHECKIF)
                     (ADDVARS (INEWCOMS (FNS DUMPINITPAGES)
                                     (VARS INITCONSTANTS)
                                     (FNS SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES))
                            (RDCOMS (FNS READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE \LOCKEDPAGEP 
                                         \LOOKUPPAGEMAP CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 
                                         \SHOWPAGETABLE \PRINTFPTOVP))
                            (EXPANDMACROFNS CHECKIF .LOCKEDVPBASE. .LOCKEDVPMASK. .PAGEMAPBASE.)
                            (MKI.SUBFNS (\NEWPAGE . MKI.NEWPAGE)
                                   (\LOCKPAGES . MKI.LOCKPAGES))
                            (RD.SUBFNS (\NEWPAGE . VNEWPAGE)
                                   (\LOCKPAGES . VLOCKPAGES))
                            (RDPTRS (\REALPAGETABLE))
                            (RDVALS (\RPTSIZE)))
                     EVAL@COMPILE
                     (ADDVARS (DONTCOMPILEFNS DUMPINITPAGES SETUPPAGEMAP ADDPME MAKEROOMFORPME 
                                     MAPPAGES READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE]
        (FNS \LOCKFN \LOCKCODE \LOCKVAR \LOCKCELL \LOCKWORDS)
        [DECLARE%: DONTCOPY
               (ADDVARS (INEWCOMS (FNS \LOCKFN \LOCKVAR \LOCKCELL \LOCKWORDS \LOCKCODE)
                               (ALLOCAL (ADDVARS (LOCKEDFNS \FAULTHANDLER \FAULTINIT \DOVE.FAULTINIT
                                                        \D01.FAULTINIT \DL.FAULTINIT \CHAIN.UP.RPT 
                                                        \MAKESPACEFORLOCKEDPAGE \PAGEFAULT \WRITEMAP
                                                        \LOOKUPPAGEMAP \LOCKEDPAGEP \LOADVMEMPAGE 
                                                        \MOVEREALPAGE \INVALIDADDR \INVALIDVP 
                                                        \SELECTREALPAGE \TRANSFERPAGE \SPECIALRP 
                                                        \UPDATECHAIN \MARKPAGEVACANT \FLUSHPAGE 
                                                        \CLEARWORDS \FLUSHVM \DONEWPAGE 
                                                        \ASSURE.FPTOVP.PAGE \DONEWEPHEMERALPAGE 
                                                        \WRITEDIRTYPAGE1 \COPYSYS0 \COPYSYS0SUBR 
                                                        \RELEASEWORKINGSET \DOFLUSHVM \DOLOCKPAGES 
                                                        \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \MP.ERROR 
                                                        RAID \DL.NEWFAULTINIT 
                                                        \DL.MARK.PAGES.UNAVAILABLE \DL.UNMAPPAGES 
                                                        \DL.ASSIGNBUFFERS \D01.ASSIGNBUFFERS 
                                                        \DOCOMPRESSVMEM \MOVEVMEMFILEPAGE 
                                                        \SET.VMEM.FULL.STATE \HINUM \LONUM \ATOMCELL
                                                        SETTOPVAL)
                                               (LOCKEDVARS \REALPAGETABLE \RPTLAST \PAGEFAULTCOUNTER
                                                      \UPDATECHAINFREQ \RPOFFSET \RPTSIZE 
                                                      \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP 
                                                      \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK 
                                                      \MAXCLEANPROBES \MINSHORTSEEK \DIRTYPAGECOUNTER
                                                      \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE 
                                                      \VMEM.PURE.LIMIT \VMEM.FULL.STATE 
                                                      \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE
                                                      \MISCSTACKBASE \DOFAULTINIT \FPTOVP 
                                                      \MACHINETYPE \VMEMACCESSFN \TELERAIDBUFFER 
                                                      \EMUDISKBUFFERS \EMUDISKBUFEND \MAXSWAPBUFFERS
                                                      \EMUBUFFERS \#EMUBUFFERS \#SWAPBUFFERS 
                                                      \#DISKBUFFERS \RCLKSECOND \RCLKMILLISECOND 
                                                      \VALSPACE \EMUSWAPBUFFERS \EM.CURSORBITMAP 
                                                      \PAGEMAP \PageMapTBL \IOCBPAGE \IOPAGE 
                                                      \MISCSTATS \DEFSPACE \InterfacePage 
                                                      \LASTVMEMFILEPAGE \DoveIORegion \MaxScreenPage
                                                      \NEWVMEMPAGEADDED]
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA VMEM.PURE.STATE])

(RPAQQ FAULTTEST T)



(* ; "Bootstrap code, run once when an image is booted")

(DEFINEQ

(\FAULTINIT
  [LAMBDA NIL                                            (* ; "Edited 30-Mar-88 17:30 by Snow")

(* ;;; "retrieves some constants from Interface page for the swapper and performs other initialization that must happen immediately.  Called when starting up, and also when \FAULTHANDLER context starts, in case init hasn't happened yet, as e.g.  from MAKEINIT")

    (SETQ \MACHINETYPE (fetch MachineType of \InterfacePage))
    [PROG NIL
          (COND
             ((EQ \MACHINETYPE \MAIKO)
              (\MAIKO.FAULTINIT)
              (RETURN NIL)))
          (OR (NEQ (fetch FPTOVPStart of \InterfacePage)
                   0)
              (\MP.ERROR \MP.OBSOLETEVMEM "No FPTOVP"))
          (COND
             ((AND (NEQ 0 (fetch (IFPAGE FullSpaceUsed) of \InterfacePage))
                   (SELECTC \MACHINETYPE
                       (\DORADO NIL)
                       (\DANDELION (EQ 0 (fetch (IFPAGE DL24BitAddressable) of \InterfacePage
                                                )))
                       (\DAYBREAK NIL)
                       T))
              (\MP.ERROR \MP.32MBINUSE "Sysout contains virtual pages not addressable by machine"
                     )))
          (SETQ \LASTDIRTYSCANPTR)
          (SELECTC \MACHINETYPE
              (\DANDELION (\DL.FAULTINIT))
              (\DAYBREAK (\DOVE.FAULTINIT))
              (\D01.FAULTINIT))                          (* ; 
                                            "Have to set \EM.CURSORBITMAP before faults can happen")

     (* ;; "But you can't call \SETIOPOINTERS on a Daybreak until after the Dove IO Region is mapped, which happens in \DL.NEWFAULTINIT")

          (\SETIOPOINTERS)
          (COND
             ((IGREATERP (fetch (IFPAGE NActivePages) of \InterfacePage)
                     (IDIFFERENCE \LASTVMEMFILEPAGE \GUARDVMEMFULL))
                                                             (* ; "Vmem getting full!")
              (\SET.VMEM.FULL.STATE]
    (COND
       ((EQ (PROG1 \DOFAULTINIT (SETQ \DOFAULTINIT NIL))
            T)                                               (* ; 
                                              "true after \FLUSHVM.  Need to rebuild some contexts")
        (replace (IFPAGE KbdFXP) of \InterfacePage with (\MAKEFRAME
                                                                     (COND
                                                                        ((fetch (LITATOM CCODEP)
                                                                            of '\KEYHANDLER)
                                                                         (FUNCTION \KEYHANDLER))
                                                                        (T '\DUMMYKEYHANDLER))
                                                                     \KBDSTACKBASE
                                                                     (IPLUS \KBDSTACKBASE 
                                                                            \StackAreaSize)
                                                                     0 0))
        (replace (IFPAGE MiscFXP) of \InterfacePage with (\MAKEFRAME
                                                                      (FUNCTION \DOMISCAPPLY)
                                                                      \MISCSTACKBASE
                                                                      (IPLUS \MISCSTACKBASE 
                                                                             \StackAreaSize)
                                                                      0 0))
        T])

(\D01.FAULTINIT
  [LAMBDA NIL                                            (* bvm%: "20-Oct-86 18:19")
    (SETQ \VMEMACCESSFN (FUNCTION \M44ACTONVMEMFILE))
    (SETQ \REALPAGETABLE (fetch (IFPAGE REALPAGETABLEPTR) of \InterfacePage))

    (* ;; "Note: these SETQ's do not reference count, since the values are all smallp's and emulator addresses (in atom space)")

    (SETQ \RPOFFSET (SIGNED (fetch (IFPAGE RPOFFSET) of \InterfacePage)
                           BITSPERWORD))
    (SETQ \RPTSIZE (fetch (IFPAGE RPTSIZE) of \InterfacePage))
                                                             (* ; 
                                                "Initialize the software clocks from alto emulator")
    (\BLT (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
          (EMADDRESS \RTCSECONDS)
          (UNFOLD 3 WORDSPERCELL))
    [SETQ \RCLKMILLISECOND (CONSTANT (OR (SMALLP \ALTO.RCLKMILLISECOND)
                                         (ERROR \ALTO.RCLKMILLISECOND 
                                                "\ALTO.RCLKMILLISECOND isn't a SMALLP???"]

(* ;;; "\ALTO.RCLKMILLISECOND must be a SMALLP here so as not to cause any refcnt or pagefault activity.  \RCLKSECOND is large and has to live on \MISCSTATS, since there is no convenient way to lock a random cell.")

    (SETQ.NOREF \RCLKSECOND (LOCF (fetch RCLKSECOND of \MISCSTATS)))

(* ;;; "Note the SETQ.NOREF for \RCLKSECOND in order to guarantee no refcnt'ing (which might pagefault) Note that these LOADBYTE expressions are compiled as constants")

    (replace (FIXP HINUM) of \RCLKSECOND with (LOADBYTE \ALTO.RCLKSECOND 16 16))
    (replace (FIXP LONUM) of \RCLKSECOND with (LOADBYTE \ALTO.RCLKSECOND 0 16))
    [COND
       ((AND (EQ \MACHINETYPE \DORADO)
             (ILEQ 5124 (fetch RVersion of \InterfacePage)))
        (replace NSHost0 of \InterfacePage with 0)
        (replace NSHost1 of \InterfacePage with 21898)
        (replace NSHost2 of \InterfacePage
           with (IPLUS (MASK.1'S 15 1)
                           (for I (N _ 0) from 1168 to 1175
                              do                         (* ; 
                           "Mufflers `2220Q' thru `2227Q' hold the bits of the basic serial number")
                                    [SETQ N (IPLUS (LLSH N 1)
                                                   (COND
                                                      ((BITTEST (RWMufMan I)
                                                              (MASK.1'S 15 1))
                                                       0)
                                                      (T 1] finally (RETURN N]
    (\CHAIN.UP.RPT)
    (\D01.ASSIGNBUFFERS])

(\D01.ASSIGNBUFFERS
  [LAMBDA NIL                                            (* bvm%: "20-Oct-86 18:21")
    (PROGN                                                   (* ; "Assign swap buffer")
           (SETQ \EMBUFVP (fetch (IFPAGE EMBUFVP) of \InterfacePage))
           (SETQ \EMBUFBASE (EMPOINTER (UNFOLD \EMBUFVP WORDSPERPAGE)))
           (SETQ \EMBUFRP (\READRP \EMBUFVP)))
    (PROG ((EMBUF (fetch (IFPAGE EMUBUFFERS) of \InterfacePage))
           (EMLEN (fetch (IFPAGE EMUBUFLENGTH) of \InterfacePage))
           EXTRALEN NPAGES)
          [add EMLEN (IDIFFERENCE EMBUF (SETQ EMBUF (CEIL EMBUF WORDSPERPAGE]
                                                             (* ; 
                                             "Round up to a page boundary and throw out the excess")
          (SETQ EXTRALEN (IMOD EMLEN WORDSPERPAGE))
          (add EXTRALEN (COND
                               ((ILESSP EXTRALEN 100)
                                (TIMES 2 WORDSPERPAGE))
                               (T WORDSPERPAGE)))
          (SETQ NPAGES (FOLDLO (SETQ EMLEN (IDIFFERENCE EMLEN EXTRALEN))
                              WORDSPERPAGE))
          (OR (IGEQ NPAGES 4)
              (RAID "No swap buffer space"))
          (SETQ \TELERAIDBUFFER (EMPOINTER EMBUF))
          (SETQ \EMUBUFFERS (\ADDBASE \TELERAIDBUFFER WORDSPERPAGE))
          (SETQ \#EMUBUFFERS (SETQ NPAGES (SUB1 NPAGES)))
          (SETQ \#SWAPBUFFERS (IMIN \MAXSWAPBUFFERS (IQUOTIENT NPAGES 2)))
          (SETQ \#DISKBUFFERS (IDIFFERENCE \#EMUBUFFERS \#SWAPBUFFERS))
          (SETQ \EMUDISKBUFFERS \EMUBUFFERS)
          (SETQ \EMUDISKBUFEND (\ADDBASE \EMUDISKBUFFERS (UNFOLD \#DISKBUFFERS WORDSPERPAGE)))
          (SETQ \EMUSWAPBUFFERS \EMUDISKBUFEND)
          (\INITBFS (\ADDBASE \EMUBUFFERS (UNFOLD NPAGES WORDSPERPAGE))
                 EXTRALEN T])

(\MAIKO.FAULTINIT
  [LAMBDA NIL                                            (* ; "Edited  2-Jan-93 12:25 by jds")
    (SETQ \VMEMACCESSFN (FUNCTION NILL))                     (* ; "This variable must be the name of function that may be ACTONVMEMFILE that may write back  from VP to FP. But , in Katana type, this function may be required (by tt)")
    (SETQ \IOCBPAGE (create POINTER
                           PAGE# _ \VP.IOCBS))

    (* ;; "MOVD all the Maiko-specific low-level functions onto their generic counterparts:")

    (\MAIKO.DO.MOVDS)
    (\MAIKO.NEWFAULTINIT)
    (SETQ \RCLKMILLISECOND 1000)
    (SETQ \RCLKSECOND 1000000)
    (\RCLK (LOCF (fetch BASECLOCK of \MISCSTATS)))   (* ; "Reset base clock ")
    (\PUTBASEPTR (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
           0 NIL)                                            (* ; "Clear the seconds timer (by tt)")
    (\PUTBASEPTR (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS))
           0 NIL)                                            (* ; "Clear the milliseconds timer")
                                                             (* SETQ \LASTVMEMFILEPAGE
                                                           (fetch (IFPAGE DLLastVmemPage) of 
                                                           \InterfacePage))
    (\SETIOPOINTERS])

(\MAIKO.NEWFAULTINIT
  [LAMBDA NIL                                   (* ; "Edited 26-Feb-88 14:07 by Osamu Nakamura")

    (* ;; "We have just started up on a Katana.  Boot code (SYSOUT Loader) may map FP to VP(VP is same map to RP). Therefore, in this function, only done the initialization of the gloval variables (particularly, the variables about Buffers). And, there is not /REALPAGETABLE in Katana.")

    (PROG ((NBUFFERS (IDIFFERENCE \DLBUFFERPAGES 2)))        (* ; "Allocate buffers")
          (\MAIKO.ASSIGNBUFFERS (create POINTER
                                           PAGE# _ \VP.BUFFERS)
                 NBUFFERS])

(\MAIKO.ASSIGNBUFFERS
  [LAMBDA (BASE NPAGES)                                 (* ; "Edited 14-May-88 18:31 by JMTurn")
    (PROGN                                                   (* ; 
                    "Allocate a page to hold name and password, and perhaps other ephemeral things")
           (replace (IFPAGE UserNameAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 1
                                                                                            )))
           (replace (IFPAGE UserPswdAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 
                                                                                            33)))
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -1))
    (PROGN                                                   (* ; "Assign swap buffer")
           (SETQ \EMBUFBASE BASE)
           (SETQ \EMBUFVP (fetch (POINTER PAGE#) of BASE))
           (SETQ \EMBUFRP \EMBUFVP)
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -1))
    (PROGN                                                   (* ; "Assign ether buffers")
           (replace (IFPAGE MDSZoneLength) of \InterfacePage with (UNFOLD 2 WORDSPERPAGE)
                  )
           (replace (IFPAGE MDSZone) of \InterfacePage with (\LOLOC BASE))
           (SETQ BASE (\ADDBASE BASE (UNFOLD 2 WORDSPERPAGE)))
           (SETQ \TELERAIDBUFFER BASE)
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -3))
    (PROGN                                                   (* ; "Divvy up buffer space")
           (SETQ \#SWAPBUFFERS (SETQ \#EMUBUFFERS NPAGES))
           (SETQ \#DISKBUFFERS 0)
           (SETQ \EMUSWAPBUFFERS (SETQ \EMUBUFFERS BASE])

(\M-VMEMSAVE
  [LAMBDA NIL                                         (* ; "Edited 20-Apr-88 10:28 by MASINTER")
    (PROG ((SCRATCHBUF \EMUSWAPBUFFERS))
          (replace (IFPAGE MISCSTACKRESULT) of \InterfacePage with T)
          [COND
             (\VMEM.PURE.LIMIT                               (* ; 
                                            "Maintaining file consistency: move high water mark up")
                    (COND
                       (VMEM.COMPRESS.FLG (\DOCOMPRESSVMEM)))
                    (SETQ \VMEM.PURE.LIMIT (fetch (IFPAGE NActivePages) of \InterfacePage]
          (COND
             ((.VMEM.CONSISTENTP.)
              (replace (IFPAGE Key) of \InterfacePage with (LOGNOT16 \IFPValidKey))
                                                             (* ; 
                                                 "Invalidate vmem and write out the Interface page")

              (* ;; "following form doesn't eval for KATANA (\TRANSFERPAGE IFPVP \FirstVmemBlock (RPTFROMRP (\READRP IFPVP)) T NIL)")

              ))
          (replace (IFPAGE Key) of \InterfacePage with \IFPValidKey)
          (\BLT SCRATCHBUF \InterfacePage WORDSPERPAGE)      (* ; 
                              "Make its current fx point at user context, i.e.  the \FLUSHVM frame")
          (replace (IFPAGE CurrentFXP) of SCRATCHBUF with (fetch (IFPAGE MiscFXP)
                                                                         of \InterfacePage))
          (SUBRCALL VMEMSAVE)
          (RETURN NIL])

(\MAIKO.NEWPAGE
  [LAMBDA (BASE NOERROR LOCK?)                        (* ; "Edited 20-Apr-88 10:28 by MASINTER")
    (SUBRCALL NEWPAGE BASE])
)



(* ;; 
"For setting up (and maybe eventually removing?) MAIKO-specific versions of the generic low-levle functions:"
)

(DEFINEQ

(\MAIKO.DO.MOVDS
  [LAMBDA NIL                                 (* ; 
                                                "Edited  2-Nov-92 03:57 by sybalsky:mv:envos")

    (* ;; "MOVD all the Maiko-specific low-level functions onto their generic counterparts.  This function is called from \MAIKO.FAULTINIT when the system is started up, and called explicitly during the LOADUP process to get everything in a state to run the ethernet.")

    (* ;; "THIS IS WHERE CHANGES SHOULD HAPPEN TO MAKE SUN LOADUPS RUN ON D-MACHINES (BY ADDING A \MAIKO.UNDO.MOVDS CALL AT VMEM SAVING TIME, AND ADDING A SYBMOL TO SAVE THE GENERIC DEFINITION ON TO THE MOVDS LIST.")

    (FOR PAIR IN \MAIKO.MOVDS DO 

                                 (* ;; "This is like MOVD, but absolutely no consing is done, frame names are not changed, etc.  So that no CONSING happens before all the MOVDs are finished -- prevents new-page allocation.")

                                            (LET [(FROMCELL (fetch (LITATOM DEFINITIONCELL)
                                                               of (CAR PAIR)))
                                                  (TOCELL (fetch (LITATOM DEFINITIONCELL)
                                                             of (CADR PAIR]
                                                 (UNINTERRUPTABLY
                                                     (replace (DEFINITIONCELL DEFPOINTER)
                                                        of TOCELL with (fetch
                                                                                (DEFINITIONCELL
                                                                                 DEFPOINTER)
                                                                                  of FROMCELL))
                                                     (replace (DEFINITIONCELL DEFCELLFLAGS)
                                                        of TOCELL with (fetch
                                                                                (DEFINITIONCELL
                                                                                 DEFCELLFLAGS)
                                                                                  of FROMCELL))
                                                     (replace (DEFINITIONCELL AUXDEFCELLFLAGS)
                                                        of TOCELL with (fetch
                                                                                (DEFINITIONCELL
                                                                                 AUXDEFCELLFLAGS)
                                                                                  of FROMCELL)))])
)

(ADDTOVAR \MAIKO.MOVDS
          (TRUE \LOCKEDPAGEP)
          (\MAIKO.NEWPAGE \NEWPAGE)
          (\MAIKO.NEWPAGE \DONEWPAGE)
          (NILL \LOCKPAGES)
          (NILL \DOLOCKPAGES)
          (NILL \DOTEMPLOCKPAGES)
          (NILL \TEMPUNLOCKPAGES)
          (NILL \UNLOCKPAGES)
          (NILL \WRITEDIRTYPAGE)
          (NILL \DIRTYBACKGROUND)
          (ZERO \COUNTREALPAGES)
          (NILL \SHOWPAGETABLE)
          (NILL CHECKPAGEMAP)
          (EVQ \PAGEFAULT)
          (EVQ \LOADVMEMPAGE)
          (NILL \LOADVMEMPAGE)
          (TRUE \MOVEVMEMFILEPAGE)
          (TRUE \VALIDADDRESSP))
(DEFINEQ

(\DOVE.FAULTINIT
  [LAMBDA NIL                                            (* ; "Edited 18-Sep-87 16:01 by bvm:")
    (DECLARE (GLOBALVARS \RCLKMILLISECOND \RCLKSECOND))
    (SETQ \VMEMACCESSFN (FUNCTION \DOVE.ACTONVMEMFILE))
    (SETQ \IOCBPAGE (create POINTER
                           PAGE# _ \VP.IOCBS))
    (COND
       ((NOT (.VMEM.CONSISTENTP.))
        (\MP.ERROR \MP.INVALIDVMEM)))
    (SETMAINTPANEL 1188)
    (\DL.NEWFAULTINIT)
    (SETMAINTPANEL 1189)
    (SETQ \RCLKMILLISECOND \DOVE.RCLKMILLISECOND)
    (SETQ.NOREF \RCLKSECOND (LOCF (fetch RCLKSECOND of \MISCSTATS)))
                                                             (* ; 
                                                    "Unfortunately, \DOVE.RCLKSECOND is not smallp")
    (replace (FIXP HINUM) of \RCLKSECOND with (CONSTANT (\HINUM \DOVE.RCLKSECOND)))
    (replace (FIXP LONUM) of \RCLKSECOND with (CONSTANT (\LONUM \DOVE.RCLKSECOND)))
    (\RCLK (LOCF (fetch BASECLOCK of \MISCSTATS)))   (* ; "Reset base clock")
    (\DoveMisc.ReadGMT (LOCF (fetch SECONDSCLOCK of \MISCSTATS)))
    (SETMAINTPANEL 1190)
    (\PUTBASEPTR (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS))
           0 NIL)                                            (* ; "Clear the milliseconds timer")
    (\DoveMisc.ReadHostID (LOCF (fetch NSHost0 of \InterfacePage)))
    (SETMAINTPANEL 1191)
    [SETQ \LASTVMEMFILEPAGE (COND
                               (NIL                          (* ; "For now, don't assume vmem is any bigger than the part in use now.  Local file system init will set it to the truth.")
                                    (SETQ \VMEM.FULL.STATE 0)(* ; "Flag to keep pages from being written off the end.  Setting it now prevents bogus vmem full interrupt at startup time.")
                                    (fetch (IFPAGE NActivePages) of \InterfacePage))
                               (T                            (* ; 
                                                           "Microcode is supposed to fill this in")
                                  (fetch (IFPAGE DLLastVmemPage) of \InterfacePage]
    (\DoveDisk.Init)
    (SETMAINTPANEL 1192)
    (\DoveDisplay.TurnOn])

(\DL.FAULTINIT
  [LAMBDA NIL                                            (* bvm%: "20-Oct-86 18:22")
    (SETQ \VMEMACCESSFN (FUNCTION \DL.ACTONVMEMFILE))
    (SETQ \IOCBPAGE (create POINTER
                           PAGE# _ \VP.IOCBS))
    (COND
       ((NOT (.VMEM.CONSISTENTP.))
        (\MP.ERROR \MP.INVALIDVMEM)))
    (\DL.NEWFAULTINIT)
    (SETQ \RCLKMILLISECOND \DLION.RCLKMILLISECOND)           (* ; 
                                                           "These are fortunately both small")
    (SETQ \RCLKSECOND \DLION.RCLKSECOND)
    (\RCLK (LOCF (fetch BASECLOCK of \MISCSTATS)))   (* ; "Reset base clock")
    [COND
       ((EQ (fetch DLTODVALID of \IOPAGE)
            0)                                               (* ; 
                                                       "Time not valid, so store zero in the clock")
        (\PUTBASEPTR (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
               0 NIL))
       (T (bind TMP (BASE _ (LOCF (fetch SECONDSCLOCK of \MISCSTATS)))
             do                                          (* ; 
                        "Loop until clock reads the same as we wrote, in case it was being updated")
                   (\PUTBASE BASE 1 (SETQ TMP (fetch DLTODLO of \IOPAGE)))
                   (\PUTBASE BASE 0 (fetch DLTODHI of \IOPAGE))
             repeatuntil (EQ (fetch DLTODLO of \IOPAGE)
                                 TMP]
    (\PUTBASEPTR (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS))
           0 NIL)                                            (* ; "Clear the milliseconds timer")
    (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE)
                           \DL.PROCESSORBUSY))               (* ; "Wait for IOP readiness")
    (replace DLPROCESSORCMD of \IOPAGE with \DL.READPID)
                                                             (* ; 
                                                        "Ask it to give the processor ID (3 words)")
    (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE)
                           \DL.PROCESSORBUSY))
    (replace NSHost0 of \InterfacePage with (fetch DLPROCESSOR0 of \IOPAGE))
    (replace NSHost1 of \InterfacePage with (fetch DLPROCESSOR1 of \IOPAGE))
    (replace NSHost2 of \InterfacePage with (fetch DLPROCESSOR2 of \IOPAGE))
    (SETQ \LASTVMEMFILEPAGE (fetch (IFPAGE DLLastVmemPage) of \InterfacePage))
    (\DL.DISKINIT T])

(\DL.NEWFAULTINIT
  [LAMBDA NIL                                            (* ; "Edited 21-Oct-87 15:40 by bvm:")

    (* ;; "We have just started up on a DLion or Daybreak.  Boot code has loaded the first n pages of the sysout into pages 2 thru n-3, except for the area covered by the map and IO page, and has built the map accordingly.  Our principal task is to build \REALPAGETABLE")

    (PROG ((NREALPAGES (fetch (IFPAGE NRealPages) of \InterfacePage))
           (FIRSTBUFFERRP \RP.STARTBUFFERS)
           (SCRATCHVP \VP.INITSCRATCH)
           (SCRATCHBASE (create POINTER
                               PAGE# _ \VP.INITSCRATCH))
           FIRSTUSEFULRP IFPAGERP IOCBRP RPTBASE VP RPTPAGES FIRSTRP NDISPLAYPAGES)
          [do (COND
                     ((for I from 0 to (SUB1 \DLBUFFERPAGES)
                         as (FPBASE _ (\ADDBASE \FPTOVP (DLFPFROMRP FIRSTBUFFERRP)))
                         by (\ADDBASE FPBASE 1)
                         do (COND
                                   ([OR (NOT (fetch FPOCCUPIED of FPBASE))
                                        (\LOCKEDPAGEP (SETQ VP (fetch FPVIRTUALPAGE
                                                                      of FPBASE]

                                    (* ;; "Can't use as buffer.  This is just a check for consistency;  you should pick \RP.STARTBUFFERS so that this isn't a problem")

                                    (RETURN T)))             (* ; 
                                                     "Unmap this page so we can use it for buffers")
                               (\WRITEMAP VP 0 \VMAP.VACANT))(* ; "Bad starting place, try again")
                      (add FIRSTBUFFERRP 1))
                     (T (RETURN]
          (SETQ FIRSTUSEFULRP (+ FIRSTBUFFERRP \DLBUFFERPAGES))
          (PROGN                                             (* ; 
                                                      "Copy vital info that booting left in page 1")
                 [COND
                    ((EQ \MACHINETYPE \DAYBREAK)

                     (* ;; "Use first buffer page for IOCB page.  Used to have to place this in a real page whose page-in-segment number was the same as that of \VP.IOCBS, but that constraint is now lifted for Daybreak.")

                     (SETQ IOCBRP FIRSTBUFFERRP)
                     (add FIRSTBUFFERRP 1))
                    (T (SETQ IOCBRP (+ (LOGAND (SUB1 (IMIN NREALPAGES 3072))
                                              65280)
                                       \VP.IOCBS))

                       (* ;; "Put IOCB page near the end of memory, but in the first 1.5 mb so that Burdock can see it.  Temporary until Steve fixes swap code to not care what RP contains IOCB's")

                       [SETQ VP (fetch FPVIRTUALPAGE of (\ADDBASE \FPTOVP (DLFPFROMRP IOCBRP]
                       (COND
                          ((\LOCKEDPAGEP VP)
                           (\MP.ERROR \MP.IOCBPAGE))
                          (T                                 (* ; 
                                                           "Unmap whoever lived in our target page")
                             (\WRITEMAP VP 0 \VMAP.VACANT]
                 (\WRITEMAP \VP.IOCBS IOCBRP \VMAP.CLEAN)
                 (\WRITEMAP SCRATCHVP 1 \VMAP.CLEAN)
                 (\BLT \IOCBPAGE SCRATCHBASE WORDSPERPAGE))
          (PROGN                                             (* ; 
                                                           "Copy InterfacePage out of segment zero")
                 (\WRITEMAP SCRATCHVP FIRSTBUFFERRP \VMAP.CLEAN)
                 (\BLT SCRATCHBASE \InterfacePage WORDSPERPAGE)
                 (\WRITEMAP \VP.IFPAGE (SETQ IFPAGERP FIRSTBUFFERRP)
                        \VMAP.CLEAN)
                 (add FIRSTBUFFERRP 1))
          [PROGN                                             (* ; 
                                                "Unmap everything that fell somewhere we can't use")
                 (\DL.UNMAPPAGES (ADD1 \FP.IFPAGE)
                        (DLFPFROMRP \RP.IOPAGE))             (* ; 
                                                           "real segment zero, map or IOPAGE")
                 (COND
                    ((EQ \MACHINETYPE \DANDELION)
                     (for NEXTBANK0 from 2MBPAGES by 2MBPAGES
                        until (> NEXTBANK0 NREALPAGES) do 

                                           (* ;; "All the `shadows of the display bank' in higher memory have restricted use;  take them out of commission for now")

                                                                 (\DL.UNMAPPAGES NEXTBANK0
                                                                        (+ NEXTBANK0 PAGESPERSEGMENT
                                                                           -1]
          (PROGN                                             (* ; "Copy Display into segment zero")
                 [SETQ NDISPLAYPAGES (COND
                                        ((EQ \MACHINETYPE \DANDELION)

                                 (* ;; "Only lock the standard screen's worth of pages on DLion, even if there are more because the sysout came from wide Daybreak.  Only this many need to be in the display bank, besides which there is a cursor bank after the display;  the rest can be vanilla locked pages.")

                                         \NP.DISPLAY)
                                        (T (IMAX \NP.DISPLAY (ADD1 \MaxScreenPage]
                                                             (* ; 
                                                     "Number of display pages in use in this image")
                 (for I from 0 to (SUB1 NDISPLAYPAGES)
                    do (\WRITEMAP (+ SCRATCHVP I)
                                  (+ \RP.DISPLAY I)
                                  \VMAP.CLEAN))              (* ; 
                                                          "Point scratch area at real segment zero")
                 (\BLT SCRATCHBASE (create POINTER
                                          PAGE# _ \VP.DISPLAY)
                       (UNFOLD NDISPLAYPAGES WORDSPERPAGE))  (* ; 
                                                           "Copy display from wherever boot put it")
                 (for I from 0 to (SUB1 NDISPLAYPAGES)
                    do (\WRITEMAP (+ SCRATCHVP I)
                                  0 \VMAP.VACANT)
                          (\WRITEMAP (+ \VP.DISPLAY I)
                                 (+ \RP.DISPLAY I)
                                 \VMAP.CLEAN))               (* ; 
                                        "Display is now where hardware wants it, so enable display")
                 (replace (IOPAGE DLDISPCONTROL) of \IOPAGE with 0))
          (COND
             ((EQ \MACHINETYPE \DAYBREAK)                    (* ; 
   "If on a daybreak, map the I/O region.  Have to do this before calling \DoveDisplay.ScreenWidth")
              (for I from 0 to (SUB1 \DOVEIORGNSIZE) do (\WRITEMAP (+ \VP.DOVEIORGN I
                                                                                      )
                                                                               (+ \RP.DOVEIORGN I)
                                                                               \VMAP.CLEAN))
              (\DoveIO.InitializeIORegionPtrs)))
          [PROG ((RPSIZE (- NREALPAGES (SETQ \RPOFFSET -1)))
                 (FIRSTVP \VP.RPT))
                (SETQ FIRSTRP (COND
                                 ((OR (> NDISPLAYPAGES \NP.DISPLAY)
                                      (AND (EQ \MACHINETYPE \DAYBREAK)
                                           (EQ (\DoveDisplay.ScreenWidth)
                                               \WIDEDOVEDISPLAYWIDTH)))

                                  (* ;; "Sysout was made on a large screen daybreak, or is now being run on one.  Need to make sure there is space for all that display")

                                  \RP.AFTERDOVEDISPLAY)
                                 (T \RP.AFTERDISPLAY)))      (* ; 
                                      "Construct real page table in segment zero after the display")
                [COND
                   ((> RPSIZE (CONSTANT (EXPT 2 15)))        (* ; 
        "We only have 15 bits for real page table numbers, so have to sacrifice the rest of memory")
                    (SETQ RPSIZE (CONSTANT (EXPT 2 15]
                [SETQ RPTPAGES (PROGN 

                                 (* ;; "This is a way of computing (FOLDHI RPSIZE*3 WORDSPERPAGE) that won't overflow when memory exceeds 10.6MB -- the first term computes RPSIZE*3/256, the second performs the FOLDHI directly on the now much smaller remainder.")

                                      (+ (TIMES3 (FOLDLO RPSIZE WORDSPERPAGE))
                                         (FOLDHI (TIMES3 (IMOD RPSIZE WORDSPERPAGE))
                                                WORDSPERPAGE]
                (COND
                   ((> (+ RPTPAGES FIRSTRP)
                       PAGESPERSEGMENT)

                    (* ;; "No space in bank zero, so put RPT in first segment after 2 megabytes, where the first `shadow' display bank lives.  No shadow bank on Daybreak, but this is as good a place as any")

                    (SETQ FIRSTRP (IMIN 2MBPAGES (- NREALPAGES RPTPAGES)))
                                                             (* ; 
                            "IMIN because we could be on a wide-display Daybreak with small memory")
                    [COND
                       ((> (+ FIRSTVP RPTPAGES)
                           \VP.BUFFERS)                      (* ; 
                                                   "Move virtual assignment backwards if necessary")
                        (SETQ FIRSTVP (COND
                                         ((< RPTPAGES \VP.BUFFERS)
                                          (- \VP.BUFFERS RPTPAGES))
                                         ((<= RPTPAGES PAGESPERSEGMENT)
                                                             (* ; 
                      "Can't fit real page table in display bank at all, so overlap smallneg space")
                                          (UNFOLD \SmallNegHi PAGESPERSEGMENT))
                                         (T                  (* ; 
                                    "Ack, more than 10.6 MB, have to slop over into smallpos space")
                                            (- (+ (UNFOLD \SmallNegHi PAGESPERSEGMENT)
                                                  PAGESPERSEGMENT)
                                               RPTPAGES]
                    (\DL.UNMAPPAGES (DLFPFROMRP FIRSTRP)
                           (DLFPFROMRP (+ FIRSTRP RPTPAGES -1)))
                                                             (* ; 
"Unmap the pages in which RPT lives.  This was already done on DLion, but can't hurt to do it again")
                    ))
                (for I from 0 to (SUB1 RPTPAGES) do 
                                                             (* ; 
                                                           "Assign pages to real page table now")
                                                                   (\WRITEMAP (+ FIRSTVP I)
                                                                          (+ FIRSTRP I)
                                                                          \VMAP.CLEAN))
                (SETQ \REALPAGETABLE (create POINTER
                                            PAGE# _ FIRSTVP))
                (\CLEARWORDS \REALPAGETABLE RPSIZE)
                (\CLEARWORDS (\ADDBASE \REALPAGETABLE RPSIZE)
                       RPSIZE)
                (\CLEARWORDS (\ADDBASE (\ADDBASE \REALPAGETABLE RPSIZE)
                                    RPSIZE)
                       RPSIZE)                               (* ; 
                                  "Clear table in three steps, since 3*RPSIZE overflows after 10MB")
                (SETQ \RPTSIZE RPSIZE)
                (COND
                   [(EQ \MACHINETYPE \DANDELION)
                    (for NEXTBANK0 from 2MBPAGES by 2MBPAGES
                       until (> NEXTBANK0 NREALPAGES) do 
                                                             (* ; 
                                                   "Mark the shadow display bank pages unavailable")
                                                                (\DL.MARK.PAGES.UNAVAILABLE
                                                                 NEXTBANK0
                                                                 (+ NEXTBANK0 PAGESPERSEGMENT -1]
                   (T 
                      (* ;; "RPT itself occupies unavailable pages;  on DLion these were marked unavailable either in segment zero after display or as part of shadow bank")

                      (\DL.MARK.PAGES.UNAVAILABLE FIRSTRP (+ FIRSTRP RPTPAGES -1))
                                                             (* ; 
                                                           "Also, Dove IO region is unavailable")
                      (\DL.MARK.PAGES.UNAVAILABLE \RP.DOVEIORGN (SUB1 (+ \RP.DOVEIORGN 
                                                                             \DOVEIORGNSIZE]
          (PROGN 
                 (* ;; "Fill in special cases in RPT -- the display, which is not where FPTOVP says it is, and all the pages that are unavailable for one reason or another.  Note: any page marked unavailable here MUST be unmapped by now, either because booting never put it where FPTOVP says it would be, there's no page there to begin with, or there's an explicit call to \WRITEMAP or \DL.UNMAPPAGES to unmap it above")

                 (SETQ RPTBASE \REALPAGETABLE)
                 [for I from 0 to (SUB1 NDISPLAYPAGES)
                    do (SETQ RPTBASE (\ADDBASE RPTBASE \RPTENTRYLENGTH)) 
                                                             (* ; "Fill in Display pages")
                          (replace (RPT VP) of RPTBASE with (+ \VP.DISPLAY I))
                          (replace (RPT FILEPAGE) of RPTBASE with (DLFPFROMRP
                                                                               (+ \RP.TEMPDISPLAY I]
                 (\DL.MARK.PAGES.UNAVAILABLE NDISPLAYPAGES \RP.IOPAGE)
                                                             (* ; 
                                        "Mark rest of segment zero plus Map and IOPAGE unavailable")
                 )
          [PROGN                                             (* ; 
                                                       "fill in main part of RPT by reading FPTOVP")
                 (for I from (ADD1 \RP.IOPAGE) to (SUB1 NREALPAGES)
                    as [FPBASE _ (\ADDBASE \FPTOVP (DLFPFROMRP (ADD1 \RP.IOPAGE]
                    by (\ADDBASE FPBASE 1) as [RPTBASE _ (fetch RPTRBASE
                                                                    of (RPTFROMRP (ADD1 
                                                                                           \RP.IOPAGE
                                                                                            ]
                    by (\ADDBASE RPTBASE \RPTENTRYLENGTH)
                    bind (LASTREALPAGE _ (DLRPFROMFP (fetch (IFPAGE NActivePages)
                                                            of \InterfacePage)))
                    do 

                          (* ;; "Fill in rest of RPT from \FPTOVP.  Could optimize this a little by special casing the area occupied by the display, but this is simpler")

                          (COND
                             ((fetch (RPT UNAVAILABLE) of RPTBASE))
                             ((AND (<= I LASTREALPAGE)
                                   (fetch FPOCCUPIED of FPBASE)
                                   [NOT (fetch (VMEMFLAGS VACANT)
                                           of (\READFLAGS (SETQ VP (fetch FPVIRTUALPAGE
                                                                          of FPBASE]
                                   (EQ I (\READRP VP)))

                              (* ;; "There is a VP assigned to this filepage, and it is still there.  False for display that got moved and any real pages that didn't get filled.  LASTREALPAGE is in case the real memory is larger than the sysout -- FPTOVP does not exist all the way")

                              (replace (RPT VP) of RPTBASE with VP)
                              (replace (RPT FILEPAGE) of RPTBASE with (DLFPFROMRP I)))
                             (T (replace (RPT EMPTY) of RPTBASE with T]
          (PROGN                                             (* ; 
                                                           "Touch up RPT with the exceptions")
                 (SETQ RPTBASE (fetch RPTRBASE of (RPTFROMRP IFPAGERP)))
                                                             (* ; "Interface Page")
                 (replace (RPT VP) of RPTBASE with \VP.IFPAGE)
                 (replace (RPT FILEPAGE) of RPTBASE with \FP.IFPAGE)
                 (replace (RPT UNAVAILABLE) of (fetch RPTRBASE of (RPTFROMRP IOCBRP))
                    with T)                              (* ; "\IOCBPAGE")
                 (\DL.MARK.PAGES.UNAVAILABLE FIRSTBUFFERRP (SUB1 FIRSTUSEFULRP))
                                                             (* ; 
                                                           "buffer pages unavailable to swapper")
                 )
          (\CHAIN.UP.RPT)
          (PROG ((NBUFFERS (- FIRSTUSEFULRP FIRSTBUFFERRP))) (* ; "Allocate buffers")
                (for I from 0 to (SUB1 NBUFFERS) do (\WRITEMAP (+ \VP.BUFFERS I)
                                                                           (+ FIRSTBUFFERRP I)
                                                                           \VMAP.CLEAN))
                (\DL.ASSIGNBUFFERS (create POINTER
                                              PAGE# _ \VP.BUFFERS)
                       NBUFFERS])

(\DL.UNMAPPAGES
  [LAMBDA (FIRSTFP LASTFP)                               (* bvm%: "14-Jan-84 14:20")

(* ;;; 
"At initialization time, unmap anything that originally lived in filepages FIRSTFP thru LASTFP")

    (for FP from FIRSTFP to LASTFP as (FPBASE _ (\ADDBASE \FPTOVP FIRSTFP))
       by (\ADDBASE FPBASE 1) when (fetch FPOCCUPIED of FPBASE)
       do (\WRITEMAP (fetch FPVIRTUALPAGE of FPBASE)
                     0 \VMAP.VACANT])

(\DL.MARK.PAGES.UNAVAILABLE
  [LAMBDA (FIRSTRP LASTRP)                               (* bvm%: "14-Jan-84 14:32")
    (for I from FIRSTRP to LASTRP as (RPTBASE _ (fetch RPTRBASE
                                                                   of (RPTFROMRP FIRSTRP)))
       by (\ADDBASE RPTBASE \RPTENTRYLENGTH) do (replace (RPT UNAVAILABLE) of RPTBASE
                                                           with T])

(\DL.ASSIGNBUFFERS
  [LAMBDA (BASE NPAGES)                                  (* bvm%: "29-Jan-85 19:05")
    (PROGN                                                   (* ; 
                    "Allocate a page to hold name and password, and perhaps other ephemeral things")
           (\CLEARWORDS BASE WORDSPERPAGE)
           (replace (IFPAGE UserNameAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 1
                                                                                            )))
           (replace (IFPAGE UserPswdAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 
                                                                                            33)))
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -1))
    (PROGN                                                   (* ; "Assign swap buffer")
           (SETQ \EMBUFBASE BASE)
           (SETQ \EMBUFVP (fetch (POINTER PAGE#) of BASE))
           (SETQ \EMBUFRP (\READRP \EMBUFVP))
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -1))
    (PROGN                                                   (* ; "Assign ether buffers")
           (replace (IFPAGE MDSZoneLength) of \InterfacePage with (UNFOLD 2 WORDSPERPAGE)
                  )
           (replace (IFPAGE MDSZone) of \InterfacePage with (\LOLOC BASE))
           (SETQ BASE (\ADDBASE BASE (UNFOLD 2 WORDSPERPAGE)))
           (SETQ \TELERAIDBUFFER BASE)
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -3))
    (PROGN                                                   (* ; "Divvy up buffer space")
           (SETQ \#SWAPBUFFERS (SETQ \#EMUBUFFERS NPAGES))
           (SETQ \#DISKBUFFERS 0)
           (SETQ \EMUSWAPBUFFERS (SETQ \EMUBUFFERS BASE])

(\CHAIN.UP.RPT
  [LAMBDA NIL                                            (* bvm%: "18-Dec-84 16:07")

(* ;;; "Maps over the Real Page Table as constructed so far and fleshes it out.  Assumes that the table is built, has all its VP and FILEPAGE entries set, and that the empty and unavailable entries are so marked.  Finishes the job by chaining together the available pages and setting the LOCKED bits")

    (PROG ((RPTBASE \REALPAGETABLE)
           (LASTEMPTY \REALPAGETABLE)
           (LASTUSED (\ADDBASE \REALPAGETABLE 1))
           FIRSTUSED)
          (SETQ FIRSTUSED LASTUSED)

     (* ;; "The `entry' \REALPAGETABLE is a dummy that points to the least recently used entry.  We use the second word of that dummy as a temporary chain head for the used pages, so that we can put all the empty pages at the front of the queue.")

          [for I from 1 to (SUB1 \RPTSIZE)
             do (SETQ RPTBASE (\ADDBASE RPTBASE \RPTENTRYLENGTH))
                   (COND
                      ((fetch (RPT UNAVAILABLE) of RPTBASE))
                      ((fetch (RPT EMPTY) of RPTBASE)
                       (replace (RPT NEXTRP) of LASTEMPTY with I)
                       (replace (RPT LOCKED) of RPTBASE with NIL)
                       (SETQ LASTEMPTY RPTBASE))
                      (T (replace (RPT NEXTRP) of LASTUSED with I)
                         (replace (RPT LOCKED) of RPTBASE with (\LOCKEDPAGEP
                                                                            (fetch (RPT VP)
                                                                               of RPTBASE)))
                         (SETQ LASTUSED RPTBASE]             (* ; 
                                    "Finally, link the end of empty chain to front of in use chain")
          (replace (RPT NEXTRP) of LASTEMPTY with (fetch (RPT NEXTRP) of 
                                                                                            FIRSTUSED
                                                                     ))
          (replace (RPT NEXTRP) of (SETQ \RPTLAST LASTUSED) with \PAGETABLESTOPFLG)
          (replace (RPT UNAVAILABLE) of \REALPAGETABLE with T)
                                                             (* ; "Dummy first entry")
      ])
)



(* ; "Pagefault handler")

(DEFINEQ

(\FAULTHANDLER
  [LAMBDA NIL                                            (* ; "Edited 27-Sep-88 00:47 by jds")
    (PROG NIL
      LP  [OR (AND \DOFAULTINIT (\FAULTINIT))
              (\PAGEFAULT (\VAG2 (LOGAND 255 (fetch (IFPAGE FAULTHI) of \InterfacePage))
                                     (fetch (IFPAGE FAULTLO) of \InterfacePage]
          (\CONTEXTSWITCH \FAULTFXP)
          (GO LP])

(\PAGEFAULT
  [LAMBDA (PTR)                                          (* bvm%: "13-Aug-85 16:38")
    (\CLOCK0 (LOCF (fetch SWAPTEMP0 of \MISCSTATS))) (* ; "Note time of start")
    (PROG ((VP (fetch (POINTER PAGE#) of PTR))
           FLAGS FILEPAGE)
          (COND
             ((fetch (VP INVALID) of VP)             (* ; 
      "Map out of bounds on Dolphin always produces -1 as the vp.  Don't know about other machines")
              (\MP.ERROR \MP.MOB "Page Fault: Map out of bounds" (AND (NEQ VP 65535)
                                                                          PTR)
                     T))
             ([NOT (fetch (VMEMFLAGS VACANT) of (SETQ FLAGS (\READFLAGS VP]
              (\MP.ERROR \MP.RESIDENT "Fault on resident page" PTR T))
             ((EQ (SETQ FILEPAGE (\LOOKUPPAGEMAP VP))
                  0)
              (\INVALIDADDR PTR))
             (T (COND
                   ((EQ (\HILOC PTR)
                        \STACKHI)                            (* ; 
                                                           "should never happen.  For debugging")
                    (\MP.ERROR \MP.STACKFAULT "Fault on stack" PTR T)))
                (\LOADVMEMPAGE VP FILEPAGE)))
          (COND
             (\NEWVMEMPAGEADDED                              (* ; 
                                                           "Only happens if VMEM.PURE.STATE on")
                    (\ASSURE.FPTOVP.PAGE)))
          [\BOXIPLUS (LOCF (fetch SWAPWAITTIME of \MISCSTATS))
                 (\BOXIDIFFERENCE (\CLOCK0 (LOCF (fetch SWAPTEMP1 of \MISCSTATS)))
                        (LOCF (fetch SWAPTEMP0 of \MISCSTATS]
                                                             (* ; "Count the time used.")
          (RETURN PTR])

(\INVALIDADDR
  [LAMBDA (ADDR)                                         (* bvm%: " 6-AUG-83 22:25")
    (\MP.ERROR \MP.INVALIDADDR "Invalid address" ADDR T])

(\INVALIDVP
  [LAMBDA (VP)                                           (* bvm%: " 6-AUG-83 22:25")
    (\MP.ERROR \MP.INVALIDVP "Invalid VP" VP])

(\FLUSHPAGE
  [LAMBDA (RPTINDEX FROMFLUSHVM)                         (* bvm%: "13-Aug-85 16:35")

(* ;;; "Write out real page RPTINDEX if it is dirty.")

    (PROG ((RPTR (fetch RPTRBASE of RPTINDEX))
           VP FP NEWFP)
          (COND
             ([AND (fetch (RPT OCCUPIED) of RPTR)
                   (fetch (VMEMFLAGS DIRTY) of (\READFLAGS (SETQ VP (fetch (RPT VP)
                                                                               of RPTR]
                                                             (* ; "Yes, page is dirty")
              (SETQ FP (fetch (RPT FILEPAGE) of RPTR))
              [COND
                 [(AND \VMEM.PURE.LIMIT (NOT FROMFLUSHVM))   (* ; 
                                "Don't sully vmem;  write page out beyond the original end of vmem")
                  (COND
                     ((ILEQ FP \VMEM.PURE.LIMIT)
                      (COND
                         ((fetch (RPT LOCKED) of RPTR)
                          (\MP.ERROR \MP.WRITING.LOCKED.PAGE)))
                      (SETQ NEWFP (add (fetch NActivePages of \InterfacePage)
                                         1))
                      (COND
                         ((IGREATERP NEWFP (IDIFFERENCE \LASTVMEMFILEPAGE \GUARDVMEMFULL))
                          (\SET.VMEM.FULL.STATE)))
                      (SETQ \NEWVMEMPAGEADDED T)
                      (\PUTBASE (.PAGEMAPBASE. VP)
                             0 NEWFP)
                      (\PUTBASE \FPTOVP NEWFP VP)
                      (\PUTBASE \FPTOVP FP \NO.VMEM.PAGE)
                      (replace (RPT FILEPAGE) of RPTR with (SETQ FP NEWFP]
                 ((.VMEM.CONSISTENTP.)
                  (replace (IFPAGE Key) of \InterfacePage with (LOGNOT16 \IFPValidKey))
                                                             (* ; 
                                                 "Invalidate vmem and write out the Interface page")
                  (SETQ \DIRTYPAGEHINT 0)                    (* ; 
                                                "So that the dirty page background writer wakes up")
                  (PROG ((IFVP (fetch (POINTER PAGE#) of \InterfacePage)))
                        (\TRANSFERPAGE IFVP \FirstVmemBlock (RPTFROMRP (\READRP IFVP))
                               T NIL]                        (* ; "Write it out")
              (COND
                 ((IGREATERP \DIRTYPAGEHINT 0)
                  (add \DIRTYPAGEHINT -1)))
              (\TRANSFERPAGE VP FP RPTINDEX T NIL])

(\LOADVMEMPAGE
  [LAMBDA (VPAGE FILEPAGE NEWPAGEFLG LOCK? DONTMOVETOPFLG)
                                                             (* bvm%: "10-Aug-85 18:08")

    (* ;; "Fault in virtual page VPAGE known to live in FILEPAGE on the vmem.  NEWPAGEFLG is true if the page is new, so should just be cleared, not loaded from vmem file.  If LOCK?  is true, locks down the page as well.  In this case, if on Dandelion, we also check for page wanting to live in a particular real page.  If DONTMOVETOPFLG is true, the real page we put this page in is not promoted to the front of the LRU queue of pages")

    (COND
       ((IGREATERP \PAGEFAULTCOUNTER \UPDATECHAINFREQ)
        (\UPDATECHAIN)))
    (add \PAGEFAULTCOUNTER 1)
    (PROG ((RPTINDEX (\SELECTREALPAGE FILEPAGE LOCK? DONTMOVETOPFLG))
           RPTBASE SPECIALRP)
          (SETQ RPTBASE (fetch RPTRBASE of RPTINDEX))
          [COND
             ((AND LOCK? (OR (EQ \MACHINETYPE \DANDELION)
                             (EQ \MACHINETYPE \DAYBREAK))
                   (SETQ SPECIALRP (\SPECIALRP VPAGE)))  (* ; 
"Must actually put FILEPAGE into special RP, and thus move old contents of SPECIALRP into RPTINDEX")
              (LET* ((SRINDEX (RPTFROMRP SPECIALRP))
                     (SRPTR (fetch RPTRBASE of SRINDEX)))
                    (\MOVEREALPAGE SRINDEX SRPTR RPTINDEX RPTBASE)
                    (SETQ RPTINDEX SRINDEX)
                    (SETQ RPTBASE SRPTR]                     (* ; 
                                                       "Fill in new RPTINDEX with appropriate data")
          (replace (RPT VP) of RPTBASE with VPAGE)
          (replace (RPT FILEPAGE) of RPTBASE with FILEPAGE)
          (replace (RPT LOCKED) of RPTBASE with LOCK?)
          (COND
             ([AND DOLOCKCHECKS (NOT LOCK?)
                   (EQ (LRSH VPAGE 8)
                       (CONSTANT (\HILOC \PAGEMAP]
              (\MP.ERROR \MP.MAPNOTLOCKED "Page of page map being loaded but not locked" VPAGE)))
          (\TRANSFERPAGE VPAGE FILEPAGE RPTINDEX NIL NEWPAGEFLG])

(\MOVEREALPAGE
  [LAMBDA (SOURCEINDEX SOURCERPT DESTINDEX DESTRPT)      (* bvm%: "14-Aug-85 13:53")

(* ;;; "Moves the page, if any, currently living in real page table SOURCEINDEX & SOURCERPT into the page indicated by DESTINDEX & DESTRPT.  The destination is assumed to have been vacated")

    (CHECK (NOT (fetch (RPT LOCKED) of SOURCERPT)))
    (replace (RPT LOCKED) of DESTRPT with NIL)
    [COND
       ((fetch (RPT OCCUPIED) of SOURCERPT)          (* ; 
                                                           "Page was not vacant to start with")
        (LET* ((SOURCEVP (fetch (RPT VP) of SOURCERPT))
               (SOURCEFLAGS (\READFLAGS SOURCEVP)))
              (replace (RPT VP) of DESTRPT with SOURCEVP)
              (replace (RPT FILEPAGE) of DESTRPT with (fetch (RPT FILEPAGE)
                                                                     of SOURCERPT))
              (\WRITEMAP \EMBUFVP (RPFROMRPT DESTINDEX)
                     0)                                      (* ; "Map buffer to target page")
              (\BLT \EMBUFBASE (create POINTER
                                      PAGE# _ SOURCEVP)
                    WORDSPERPAGE)                            (* ; "move data to buffer page")
              (\WRITEMAP \EMBUFVP \EMBUFRP 0)                (* ; 
                                                           "Restore buffer to its proper page")
              (\WRITEMAP SOURCEVP (RPFROMRPT DESTINDEX)
                     SOURCEFLAGS)                            (* ; "Set flags and new RP for page")
              ]
    DESTINDEX])

(\LOOKUPPAGEMAP
  [LAMBDA (VP)                                           (* bvm%: "20-Oct-86 18:26")

    (* ;; "Returns the pagemap entry for VP, which is expected to be in bounds.  High bit of result is the lock bit.  Zero denotes absence")

    (LET [(PRIMENTRY (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP]
         (COND
            ((EQ PRIMENTRY \EMPTYPMTENTRY)
             0)
            (T (\GETBASE \PAGEMAP (IPLUS PRIMENTRY (fetch (VP SECONDARYKEY) of VP])

(\VALIDADDRESSP
  [LAMBDA (BASE)                                         (* bvm%: "16-Jun-86 11:30")
    (NEQ 0 (\LOOKUPPAGEMAP (fetch (POINTER PAGE#) of BASE])

(\LOCKEDPAGEP
  [LAMBDA (VP TEMP)                                      (* bvm%: "18-Feb-85 18:08")

(* ;;; "True if VP is locked.  If TEMP is NIL consults only the locked page table;  otherwise, also checks for `temporary' locked page")

    (OR (NEQ 0 (LOGAND (.LOCKEDVPMASK. VP)
                      (\GETBASE (.LOCKEDVPBASE. VP)
                             0)))
        (UNLESSRDSYS (AND TEMP (NOT (fetch (VMEMFLAGS VACANT) of (\READFLAGS VP)))
                          (fetch (RPT LOCKED) of (fetch RPTRBASE
                                                            of (RPTFROMRP (\READRP VP])

(\SELECTREALPAGE
  [LAMBDA (NEWFP LOCK? DONTMOVETOPFLG)                   (* bvm%: "10-Aug-85 18:08")

    (* ;; "Selects a real page, flushing it if necessary, and returns the RPT index of the page.  NEWFP, if supplied, is the filepage that will be read into here.  This might influence page choice by minimizing seek time.  LOCK?  means caller intends to lock the page, which constrains which real pages it can fall into.  The selected page is moved to the back of the LRU queue, so that it won't be selected again soon, unless DONTMOVETOPFLG is true.  If DONTMOVETOPFLG is REMOVE then the page is spliced out of the chain forever.")

    (PROG ((TRIES 0)
           (CNTR \MAXCLEANPROBES)
           (DISTANCE \MINSHORTSEEK)
           PREVRPT PREVINDEX RPTINDEX RPTBASE FP FLAGS)
      RETRY
          (SETQ PREVRPT \REALPAGETABLE)
          (until (EQ (SETQ RPTINDEX (fetch (RPT NEXTRP) of PREVRPT))
                         \PAGETABLESTOPFLG)
             do (SETQ RPTBASE (fetch RPTRBASE of RPTINDEX))
                   [COND
                      ((fetch (RPT EMPTY) of RPTBASE)
                       (RETURN PREVRPT))
                      ((NOT (fetch (RPT OCCUPIED) of RPTBASE))
                       (\MP.ERROR \MP.CHAIN.UNAVAIL "UNAVAILABLE page on Chain"))
                      ([AND (NOT (fetch (RPT LOCKED) of RPTBASE))
                            [NOT (fetch (VMEMFLAGS REFERENCED)
                                    of (SETQ FLAGS (\READFLAGS (fetch (RPT VP) of RPTBASE
                                                                          ]
                            (OR (NOT LOCK?)
                                (.LOCKABLERP. (RPFROMRPT RPTINDEX]

                       (* ;; "Page is unlocked and unreferenced, so is good candidate for flushing.  LOCK?  check is to avoid locking a page into a real page that might be desired by code that cares about real pages")

                       (COND
                          ([OR (NOT (fetch (VMEMFLAGS DIRTY) of FLAGS))
                               (PROGN (SETQ FP (fetch (RPT FILEPAGE) of RPTBASE))
                                      (COND
                                         ((SELECTQ \VMEM.INHIBIT.WRITE
                                              (NIL [SELECTQ \VMEM.FULL.STATE
                                                       (NIL  (* ; "Normal, can write anything")
                                                            T)
                                                       (T    (* ; 
                                                     "Vmem is full and clean, don't write anything")
                                                          NIL)
                                                       (PROGN 
                                                             (* ; 
              "Vmem is full, but sullied, so might as well write anything for which there is space")
                                                              (AND (ILEQ FP \LASTVMEMFILEPAGE)
                                                                   (OR (NULL \VMEM.PURE.LIMIT)
                                                                       (IGREATERP FP \VMEM.PURE.LIMIT
                                                                              ])
                                              (NEW           (* ; 
      "Only allowed to write old pages, since new pages might just have to get moved a second time")
                                                   (ILEQ FP \VMEM.PURE.LIMIT))
                                              (PROGN         (* ; 
                                                           "We are forbidden from writing any page")
                                                     NIL))
                                          (COND
                                             ((OR (ILEQ CNTR 0)
                                                  (NULL NEWFP)
                                                  (ILESSP (IABS (IDIFFERENCE FP NEWFP))
                                                         DISTANCE))
                                                             (* ; 
                               "Page is near replacement, or we have given up trying for closeness")
                                              T)
                                             (T              (* ; 
                                                       "Page is too far away from replacement page")
                                                (SETQ CNTR (SUB1 CNTR))
                                                [COND
                                                   ((ILESSP DISTANCE \MAXSHORTSEEK)
                                                             (* ; "Get more liberal")
                                                    (SETQ DISTANCE (LLSH DISTANCE 1]
                                                NIL]
                           [COND
                              (DOLOCKCHECKS (COND
                                               ((fetch (RPT LOCKED) of RPTBASE)
                                                (\MP.ERROR \MP.FLUSHLOCKED 
                                                       "Attempt to displace locked page" RPTBASE))
                                               ((EQ (fetch (RPT VPSEG) of RPTBASE)
                                                    (CONSTANT (\HILOC \PAGEMAP)))
                                                (\MP.ERROR \MP.MAPNOTLOCKED 
                                                       "A page of the page map is not locked" RPTBASE
                                                       ]
                           (\FLUSHPAGE RPTINDEX)
                           (\WRITEMAP (fetch (RPT VP) of RPTBASE)
                                  0 \VMAP.VACANT)
                           (replace (RPT EMPTY) of RPTBASE with T)
                           (RETURN PREVRPT]
                   (SETQ PREVRPT RPTBASE)
                   (SETQ PREVINDEX RPTINDEX) finally 

                                 (* ;; "Couldn't find an unreffed page because all pages were touched since last \UPDATECHAIN.  Do another, which clears ref bits, and try again")

                                                   (COND
                                                      ((EQ TRIES 0)
                                                       (SETQ TRIES 1)
                                                       (\UPDATECHAIN))
                                                      [(AND (EQ TRIES 1)
                                                            \VMEM.INHIBIT.WRITE)
                                                       (SETQ \VMEM.INHIBIT.WRITE)
                                                       (COND
                                                          ((AND (NEQ \MACHINETYPE \DANDELION)
                                                                (NEQ \MACHINETYPE \DAYBREAK))

                                 (* ;; "Don't call RAID on a DLion, since the interface is so bad.  Dorado user might want to know that we're smashing \VMEM.INHIBIT.WRITE")

                                                           (RAID 
                                      "No clean vmem pages to reuse, must write one.  ^N to continue"
                                                                 ]
                                                      (T (\MP.ERROR \MP.SELECTLOOP 
                                                                "Loop in \SELECTREALPAGE")))
                                                   (GO RETRY))
          (SELECTQ DONTMOVETOPFLG
              (NIL                                           (* ; 
                           "Move this page to head of chain, so that it won't be picked again soon")
                   (replace (RPT NEXTRP) of PREVRPT with (fetch (RPT NEXTRP)
                                                                        of RPTBASE))
                                                             (* ; "Splice RPTINDEX out of chain")
                   (replace (RPT NEXTRP) of \RPTLAST with RPTINDEX)
                                                             (* ; "Put new page at end of chain")
                   (replace (RPT NEXTRP) of (SETQ \RPTLAST RPTBASE) with 
                                                                                  \PAGETABLESTOPFLG))
              (REMOVE                                        (* ; 
                                                         "Splice this page out of chain altogether")
                      (replace (RPT NEXTRP) of PREVRPT with (fetch (RPT NEXTRP)
                                                                           of RPTBASE))
                      (replace (RPT NEXTRP) of RPTBASE with \PAGETABLESTOPFLG))
              NIL)
          (RETURN RPTINDEX])

(\SPECIALRP
  [LAMBDA (VP)                                           (* edited%: " 9-Aug-85 17:14")

    (* ;; "for \DANDELION, some virtual pages must be mapped into special real pages.  This function returns the corresponding real page")

    (SELECTC (FOLDLO VP PAGESPERSEGMENT)
        ((FOLDLO \VP.STACK PAGESPERSEGMENT) 
             (IPLUS VP (IDIFFERENCE \RP.STACK \VP.STACK)))
        ((FOLDLO \VP.DISPLAY PAGESPERSEGMENT) 
             (IPLUS VP (IDIFFERENCE \RP.DISPLAY \VP.DISPLAY)))
        NIL])

(\TRANSFERPAGE
  [LAMBDA (VP FILEPAGE RPTINDEX WRITE? NEWPAGE?)         (* MPL "27-Jul-85 21:28")

    (* ;; "Transfers virtual page VP between page FILEPAGE of the vmem and real page RPTINDEX.  WRITE?  indicates direction of transfer.  If NEWPAGE?, then page does not exist on file, and is simply cleared")

    (PROG (NEWFLAGS)
          (COND
             (WRITE? (FLIPCURSORBAR 15))
             (T (FLIPCURSORBAR 0)))
          (SETQ NEWFLAGS (COND
                            (NEWPAGE? \VMAP.DIRTY)
                            (WRITE? (LOGAND (\READFLAGS VP)
                                           (LOGNOT16 \VMAP.DIRTY)))
                            (T 0)))
          (COND
             ((AND WRITE? (fetch (RPT LOCKED) of (fetch RPTRBASE of RPTINDEX)))

              (* ;; "Writing a locked page: can't diddle map, because others might die, so do this in the straightforward way")

              (\BLT \EMBUFBASE (create POINTER
                                      PAGE# _ VP)
                    WORDSPERPAGE)                            (* ; 
                                                 "Copy page into buffer, then write the buffer out")
              (\ACTONVMEMFILE FILEPAGE \EMBUFBASE 1 T)
              (SETQ \LASTACCESSEDVMEMPAGE FILEPAGE))
             ((NOT NEWPAGE?)                                 (* ; 
        "Map the buffer page into the target real page, read/write the page, then set the map back")
              (\WRITEMAP VP 0 \VMAP.VACANT)                  (* ; 
                      "Unmap VP so that we don't have two virtual pages pointing at same real page")
              (\WRITEMAP \EMBUFVP (RPFROMRPT RPTINDEX)
                     0)                                      (* ; "Map buffer to target page")
              (\ACTONVMEMFILE FILEPAGE \EMBUFBASE 1 WRITE?)
                                                             (* ; "Do the i/o")
              (\WRITEMAP \EMBUFVP \EMBUFRP 0)                (* ; 
                                                           "Restore buffer to its proper page")
              (SETQ \LASTACCESSEDVMEMPAGE FILEPAGE)))
          (\WRITEMAP VP (RPFROMRPT RPTINDEX)
                 NEWFLAGS)                                   (* ; "Set flags for page")
          (COND
             (NEWPAGE?                                       (* ; 
             "Not on file yet, so clear it.  Couldn't do this sooner because the flags weren't set")
                    (\CLEARWORDS (create POINTER
                                        PAGE# _ VP)
                           WORDSPERPAGE)))
          (COND
             (WRITE? (FLIPCURSORBAR 15)
                    (\BOXIPLUS (LOCF (fetch SWAPWRITES of \MISCSTATS))
                           1))
             (T (FLIPCURSORBAR 0)
                (\BOXIPLUS (LOCF (fetch PAGEFAULTS of \MISCSTATS))
                       1])

(\UPDATECHAIN
  [LAMBDA NIL                                            (* bvm%: "30-Jul-85 15:20")
                                                             (* ; 
                                                           "Sorts the page chain by reference bit")
    (CHECK (NOT \INTERRUPTABLE))
    (PROG ((RPTINDEX (fetch (RPT NEXTRP) of \REALPAGETABLE))
           (CHAIN0 \REALPAGETABLE)
           (CHAIN1 (\ADDBASE \REALPAGETABLE 2))
           RPTR VP FLAGS HEAD1)
          (SETQ HEAD1 CHAIN1)

     (* ;; "HEAD1 = CHAIN1 is just a holding cell for the second Chain we temporarily create inside here.  Use the unused third word of the dummy header entry of \REALPAGETABLE")

          (replace (RPT NEXTRP) of CHAIN0 with \PAGETABLESTOPFLG)
          (replace (RPT NEXTRP) of CHAIN1 with \PAGETABLESTOPFLG)
          (do (SETQ RPTR (fetch RPTRBASE of RPTINDEX))
                 (SETQ VP (fetch (RPT VP) of RPTR))
                 [SETQ FLAGS (COND
                                ((fetch (RPT EMPTY) of RPTR)
                                 0)
                                (T (\READFLAGS VP]
                 (COND
                    ((OR (fetch (RPT LOCKED) of RPTR)
                         (PROGN (COND
                                   ([AND DOLOCKCHECKS (EQ (fetch (RPT VPSEG) of RPTR)
                                                          (CONSTANT (\HILOC \PAGEMAP]
                                    (\MP.ERROR \MP.MAPNOTLOCKED 
                                           "A page of the page map is not locked" RPTR)))
                                (fetch (VMEMFLAGS REFERENCED) of FLAGS)))
                                                             (* ; 
                                                         "Page referenced or locked, put on CHAIN1")
                     (\WRITEMAP VP (RPFROMRPT RPTINDEX)
                            (LOGAND FLAGS (LOGNOT16 \VMAP.REF)))
                                                             (* ; "Turn off ref bit")
                     (replace (RPT NEXTRP) of CHAIN1 with RPTINDEX)
                     (SETQ CHAIN1 RPTR))
                    (T                                       (* ; 
                                                  "Page was not referenced recently, put on CHAIN0")
                       (replace (RPT NEXTRP) of CHAIN0 with RPTINDEX)
                       (SETQ CHAIN0 RPTR)))
                 (SETQ RPTINDEX (fetch (RPT NEXTRP) of RPTR)) 
                                                             (* ; "Look at next page in old chain")
             repeatuntil (EQ RPTINDEX \PAGETABLESTOPFLG))
          (replace (RPT NEXTRP) of CHAIN1 with \PAGETABLESTOPFLG)
                                                             (* ; "End of the line")
          (replace (RPT NEXTRP) of CHAIN0 with (fetch (RPT NEXTRP) of HEAD1))
                                                             (* ; 
                                                        "Link end of CHAIN0 to beginning of CHAIN1")
          (SETQ \RPTLAST (COND
                            ((EQ HEAD1 CHAIN1)               (* ; "Nothing on CHAIN1 ??!!")
                             CHAIN0)
                            (T CHAIN1)))                     (* ; 
                                                           "Pointer to end of complete chain")
          (SETQ \DIRTYPAGECOUNTER (SETQ \PAGEFAULTCOUNTER 0])
)



(* ; "Allocating and locking new pages")

(DEFINEQ

(\NEWPAGE
  [LAMBDA (BASE NOERROR LOCK?)                (* ; 
                                                "Edited 24-Oct-92 12:45 by sybalsky:mv:envos")

(* ;;; "Creates and returns a new page located at virtual addr BASE")

    (* ;; "If LOCK?, lock the page into real memory (A NOP on nonXerox machines!)")

    (UNINTERRUPTABLY
        (COND
           [(NOT (\MISCAPPLY* (FUNCTION \DONEWPAGE)
                        BASE LOCK?))                         (* ; "Failed, page exists")
            (COND
               ((NOT NOERROR)
                (\MP.ERROR \MP.NEWPAGE "Attempt to allocate already existing page" BASE T)))
            (COND
               (LOCK? (\LOCKPAGES BASE 1]
           ((IGREATERP (fetch (IFPAGE NActivePages) of \InterfacePage)
                   (IDIFFERENCE \LASTVMEMFILEPAGE \GUARDVMEMFULL))
                                                             (* ; "Vmem getting full!")
            (\SET.VMEM.FULL.STATE)))
        BASE)])

(\DONEWPAGE
  [LAMBDA (BASE LOCK? INTERNALFLG)                       (* bvm%: "13-Aug-85 16:32")

(* ;;; "Allocates new page at BASE, locking it if LOCK?  is true.  Returns vmemfile page# on success, NIL if page already exists.  Must be run in safe context! because it can cause vmem activity")

    (AND \DOFAULTINIT (\FAULTINIT))                      (* ; 
              "Only an issue when INIT.SYSOUT starts.  Perhaps there is a better place to put this")
    (PROG ((VP (fetch (POINTER PAGE#) of BASE))
           MAPBASE LOCKBASE FILEPAGE NEXTPM ERRCODE)
          (RETURN (COND
                     ((fetch (VP INVALID) of VP)
                      (\INVALIDVP VP)
                      NIL)
                     (T (SETQ MAPBASE (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)))
                        (COND
                           ((EQ MAPBASE \EMPTYPMTENTRY)      (* ; 
                                                          "Need to create a new second-level block")
                            (SETQ NEXTPM (fetch (IFPAGE NxtPMAddr) of \InterfacePage))
                            [COND
                               ((EVENP NEXTPM WORDSPERPAGE)

                                (* ;; "Need a new secondary pagemap page.  This recursion is ok, because we know that SETUPPAGEMAP assures that the pagemap pages for all the pages in secondary map space were created at MAKEINIT time")

                                (OR (\DONEWPAGE (\ADDBASE \PAGEMAP NEXTPM)
                                           T T)
                                    (RETURN (\MP.ERROR \MP.NEWMAPPAGE 
                                                   "\DONEWPAGE failed to allocate new map page"]
                            (\PUTBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)
                                   NEXTPM)
                            (replace (IFPAGE NxtPMAddr) of \InterfacePage
                               with (IPLUS NEXTPM \PMblockSize))
                            (SETQ MAPBASE NEXTPM)))
                        [SETQ MAPBASE (\ADDBASE \PAGEMAP (IPLUS MAPBASE (fetch (VP SECONDARYKEY)
                                                                           of VP]
                        (COND
                           ((NEQ (\GETBASE MAPBASE 0)
                                 0)                          (* ; "Page exists")
                            (RETURN NIL)))
                        (SETQ FILEPAGE (add (fetch (IFPAGE NActivePages) of 
                                                                                       \InterfacePage
                                                       )
                                              1))
                        (replace (IFPAGE NDirtyPages) of \InterfacePage with FILEPAGE)
                                                             (* ; "Currently a redundant field")
                        [COND
                           (LOCK? (SETQ FILEPAGE (\MAKESPACEFORLOCKEDPAGE VP FILEPAGE))
                                  (\PUTBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP))
                                         0
                                         (LOGOR (.LOCKEDVPMASK. VP)
                                                (\GETBASE LOCKBASE 0]
                        (\PUTBASE \FPTOVP FILEPAGE VP)
                        (\PUTBASE MAPBASE 0 FILEPAGE)
                        (\LOADVMEMPAGE VP FILEPAGE T LOCK?)
                        (COND
                           (INTERNALFLG (SETQ \NEWVMEMPAGEADDED T))
                           (T                                (* ; 
                                                          "Make sure \FPTOVP extended if necessary")
                              (\ASSURE.FPTOVP.PAGE)))
                        FILEPAGE])

(\ASSURE.FPTOVP.PAGE
  [LAMBDA NIL                                            (* bvm%: "13-Aug-85 16:29")

    (* ;; "Called at the end of some swapping operation that added one or more pages to the vmem file, setting \NEWVMEMPAGEADDED true.  If we're going to need a new page of \FPTOVP soon, do it now while there's still maneuvering room.  The allowance below is for the worst case, which can happen when VMEM.PURE.STATE is on and \NEWPAGE was called needing a new pagemap page as well, in which case we could have as many as the following new vmem pages before we're home safe --- 1: \NEWPAGE added a page --- 2: a page was displaced by the new page and written to the end of the vmem --- 3: a new pagemap page was needed --- 4: it displaced a page to end of vmem --- 5: the new \FPTOVP page below --- 6: a page displaced by same.  --- --- Alternatively, it could have been the new \FPTOVP page that needed a new pagemap block.  Will never have both needing a new pagemap block, since there are several pagemap blocks per page")

    (LET ((FILEPAGE (fetch (IFPAGE NActivePages) of \InterfacePage)))
         (COND
            ((IGREATERP (IMOD FILEPAGE WORDSPERPAGE)
                    (IDIFFERENCE WORDSPERPAGE 7))            (* ; 
                                           "This is a no-op if the page has already been allocated")
             (\DONEWPAGE (\ADDBASE \FPTOVP (CEIL FILEPAGE WORDSPERPAGE))
                    T T)))
         (SETQ \NEWVMEMPAGEADDED NIL])

(\MAKESPACEFORLOCKEDPAGE
  [LAMBDA (VP FILEPAGE)                                  (* bvm%: "29-Jun-86 17:44")

    (* ;; "VP is a page to be locked, FILEPAGE its home.  Returns a possibly new file page where VP will now live, after having kicked the former resident of the new file page into VP's old FILEPAGE")

    (PROG (DESIREDFP OLDVP FPBASE)
          [SETQ DESIREDFP (SELECTC (FOLDLO VP PAGESPERSEGMENT)
                              ((FOLDLO \VP.STACK PAGESPERSEGMENT) 
                                   (IPLUS VP (IDIFFERENCE (DLFPFROMRP \RP.STACK)
                                                    \VP.STACK)))
                              ((FOLDLO \VP.DISPLAY PAGESPERSEGMENT) 
                                                             (* ; 
                        "Display lives in a fixed place in file, but does not land there initially")
                                   (IPLUS VP (IDIFFERENCE (DLFPFROMRP \RP.TEMPDISPLAY)
                                                    \VP.DISPLAY)))
                              ((FOLDLO \VP.FPTOVP PAGESPERSEGMENT) 
                                                             (* ; 
                         "A new page of FPTOVP has to be continguous on file with other such pages")
                                   (IPLUS VP (IDIFFERENCE (DLFPFROMRP \RP.FPTOVP)
                                                    \VP.FPTOVP)))
                              (COND
                                 ((AND (ILEQ FILEPAGE (fetch LastLockedFilePage of 
                                                                                       \InterfacePage
                                                             ))
                                       (IGREATERP FILEPAGE (DLFPFROMRP \RP.MISCLOCKED)))
                                                             (* ; 
                     "Page is in a good place already.  It probably was once locked, then unlocked")
                                  (RETURN FILEPAGE))
                                 (T                          (* ; 
                                                          "Put it after all the other locked pages")
                                    (add (fetch LastLockedFilePage of \InterfacePage)
                                           1]
          (COND
             ((AND (fetch FPOCCUPIED of (SETQ FPBASE (\ADDBASE \FPTOVP DESIREDFP)))
                   (NEQ (SETQ OLDVP (fetch FPVIRTUALPAGE of FPBASE))
                        VP))                                 (* ; 
                                                          "Someone else lives here, so move it out")
              (\MOVEVMEMFILEPAGE OLDVP DESIREDFP FILEPAGE)))
          (RETURN DESIREDFP])

(\MOVEVMEMFILEPAGE
  [LAMBDA (VP OLDFP NEWFP)                               (* bvm%: "18-Nov-84 14:14")
    (PROG ((FLAGS (\READFLAGS VP))
           RP)
          (COND
             ((fetch (VMEMFLAGS VACANT) of FLAGS)    (* ; 
                                                           "Page not resident, so pull it in")
              (\LOADVMEMPAGE VP OLDFP)
              (SETQ FLAGS \VMAP.CLEAN))
             ((\LOCKEDPAGEP VP)
              (\MP.ERROR \MP.BADLOCKED "Locked page is in the way" VP)))
          (\WRITEMAP VP (SETQ RP (\READRP VP))
                 (LOGOR FLAGS \VMAP.DIRTY))                  (* ; 
                           "Mark page dirty, so that it will eventually be written to its new home")
          (replace (RPT FILEPAGE) of (fetch RPTRBASE of (RPTFROMRP RP)) with
                                                                                        NEWFP)
                                                             (* ; "Tell RPT where VP now lives")
          (\PUTBASE (.PAGEMAPBASE. VP)
                 0 NEWFP)                                    (* ; "Tell \PAGEMAP about it")
          (\PUTBASE \FPTOVP NEWFP VP)                        (* ; "...  and \FPTOVP")
      ])

(\NEWEPHEMERALPAGE
  [LAMBDA (BASE NOERROR)                                 (* bvm%: "26-NOV-82 15:40")

(* ;;; "Creates and returns a new page located at virtual addr BASE, mapping it permanently into some real page but leaving it out of the vmem file")

    (\MISCAPPLY* (FUNCTION \DONEWEPHEMERALPAGE)
           BASE NOERROR])

(\DONEWEPHEMERALPAGE
  [LAMBDA (BASE NOERROR)                                 (* bvm%: "30-Oct-86 16:47")

(* ;;; "Creates and returns a new page located at virtual addr BASE, mapping it permanently into some real page but leaving it out of the vmem file")

    (LET ((VP (fetch (POINTER PAGE#) of BASE))
          MAPBASE PREVRP RPTINDEX RPTR)
         (COND
            ((fetch (VP INVALID) of VP)
             (\INVALIDVP VP)
             NIL)
            ([OR (AND (NEQ (SETQ MAPBASE (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY)
                                                                  of VP)))
                           \EMPTYPMTENTRY)
                      (NEQ (\GETBASE \PAGEMAP (IPLUS MAPBASE (fetch (VP SECONDARYKEY)
                                                                of VP)))
                           0))
                 (NOT (fetch (VMEMFLAGS VACANT) of (\READFLAGS VP]
                                                             (* ; 
                                                          "Page is in the vmem already, so no hope")
             (COND
                ((NOT NOERROR)
                 (\MP.ERROR \MP.NEWPAGE "Page already exists " BASE T)))
             BASE)
            (T (COND
                  ((IGREATERP \PAGEFAULTCOUNTER \UPDATECHAINFREQ)
                   (\UPDATECHAIN)))
               (add \PAGEFAULTCOUNTER 1)
               (SETQ RPTINDEX (\SELECTREALPAGE NIL T 'REMOVE))
                                                             (* ; "Find a page to put this in")
               (SETQ RPTR (fetch RPTRBASE of RPTINDEX))
                                                             (* ; 
                                                       "Fill in new RPTINDEX with appropriate data")
               (replace (RPT VP) of RPTR with \RPT.UNAVAILABLE)
               (replace (RPT FILEPAGE) of RPTR with VP)
                                                             (* ; "For debugging only")
               (FLIPCURSORBAR 0)
               (\WRITEMAP VP (RPFROMRPT RPTINDEX)
                      \VMAP.DIRTY)                           (* ; "Set flags for page")
               (\CLEARWORDS (create POINTER
                                   PAGE# _ VP)
                      WORDSPERPAGE)                          (* ; "Clear new page")
               (FLIPCURSORBAR 0)
               (\BOXIPLUS (LOCF (fetch PAGEFAULTS of \MISCSTATS))
                      1)
               (COND
                  (\NEWVMEMPAGEADDED (\ASSURE.FPTOVP.PAGE)))
               BASE])

(\LOCKPAGES
  [LAMBDA (BASE NPAGES)                                  (* bvm%: "26-NOV-82 15:17")

    (* ;; "Needs to be done in safe stack context because might cause vmem transfer")

    (\MISCAPPLY* (FUNCTION \DOLOCKPAGES)
           BASE NPAGES)
    BASE])

(\DOLOCKPAGES
  [LAMBDA (BASE NPAGES)                                  (* ; "Edited 21-Oct-87 15:49 by bvm:")
    (for I from 0 to (SUB1 NPAGES) bind (VP _ (fetch (POINTER PAGE#) of
                                                                                         BASE))
                                                     FILEPAGE MAPBASE RPTBASE RPINDEX RP MASK 
                                                     LOCKBASE
       do [COND
                 ((fetch (VP INVALID) of VP)
                  (\INVALIDVP VP))
                 [(EQ (SETQ MAPBASE (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)))
                      \EMPTYPMTENTRY)
                  (\INVALIDADDR (ADDBASE BASE (UNFOLD I WORDSPERPAGE]
                 (T [SETQ MAPBASE (\ADDBASE \PAGEMAP (IPLUS MAPBASE (fetch (VP SECONDARYKEY)
                                                                       of VP]
                    (SETQ FILEPAGE (\GETBASE MAPBASE 0))
                    (COND
                       ((EQ 0 (LOGAND (SETQ MASK (.LOCKEDVPMASK. VP))
                                     (\GETBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP))
                                            0)))             (* ; "Not locked yet")
                        (COND
                           ((fetch VACANT of (\READFLAGS VP))
                                                             (* ; 
                                       "Bring locked page into core so we can move it if necessary")
                            (\LOADVMEMPAGE VP FILEPAGE NIL T)))
                        [SETQ RPINDEX (RPTFROMRP (SETQ RP (\READRP VP]
                        (SETQ RPTBASE (fetch RPTRBASE of RPINDEX))
                        [COND
                           ((AND (NOT (.LOCKABLERP. RP))
                                 (NOT (\SPECIALRP VP)))

                            (* ;; "Page already swapped in, but lives in a real page that might need to get bumped (e.g., for stack), so move it now.  If \SPECIALRP is true then we know that the page got swapped into the right place, so no need to move it.")

                            (LET* ((NEWINDEX (\SELECTREALPAGE NIL T))
                                   (NEWRPT (fetch RPTRBASE of NEWINDEX)))
                                  (\MOVEREALPAGE RPINDEX RPTBASE NEWINDEX NEWRPT)
                                  (replace (RPT EMPTY) of RPTBASE with T)
                                                             (* ; "Mark vacated RPT entry empty")
                                  (SETQ RPTBASE NEWRPT)
                                  (SETQ RP (RPFROMRPT NEWINDEX]
                        (COND
                           ((NEQ FILEPAGE (SETQ FILEPAGE (\MAKESPACEFORLOCKEDPAGE VP FILEPAGE)))

                            (* ;; "Moving to a new page, so have to mark this locked page dirty so that it will eventually get written to its new home")

                            (\WRITEMAP VP RP (LOGOR \VMAP.DIRTY \VMAP.REF))
                            (replace (RPT FILEPAGE) of RPTBASE with FILEPAGE)
                            (\PUTBASE \FPTOVP FILEPAGE VP)
                            (\PUTBASE MAPBASE 0 FILEPAGE)))
                        (\PUTBASE LOCKBASE 0 (LOGOR MASK (\GETBASE LOCKBASE 0)))
                                                             (* ; "Set lock bit in page map")
                        (replace (RPT LOCKED) of RPTBASE with T]
             (add VP 1) finally (COND
                                           (\NEWVMEMPAGEADDED 
                                                             (* ; 
        "If we had to load or rearrange pages, vmem could have gotten bigger if VMEM.PURE.STATE on")
                                                  (\ASSURE.FPTOVP.PAGE])

(\TEMPLOCKPAGES
  [LAMBDA (BASE NPAGES)                                  (* bvm%: "10-Aug-85 18:17")

(* ;;; "`Temporarily' locks BASE for NPAGES, i.e. ensures that the swapper will not move the pages.  Information vanishes at logout etc.")

    (\MISCAPPLY* (FUNCTION \DOTEMPLOCKPAGES)
           BASE NPAGES])

(\DOTEMPLOCKPAGES
  [LAMBDA (BASE NPAGES)                                  (* ; "Edited 21-Oct-87 15:49 by bvm:")

    (* ;; "`Temporarily' locks BASE for NPAGES, i.e. ensures that the swapper will not move the pages.  Information vanishes at logout etc.  This function must be locked because it manipulates the page table table.  Runs in MISC context")

    (to NPAGES as VP from (fetch (POINTER PAGE#) of BASE) bind RPTBASE 
                                                                                    RPINDEX RP
       do (\TOUCHPAGE BASE)                              (* ; "Touch page in case not resident")
             [SETQ RPINDEX (RPTFROMRP (SETQ RP (\READRP VP]
             (SETQ RPTBASE (fetch RPTRBASE of RPINDEX))
             [COND
                ((NOT (.LOCKABLERP. RP))

                 (* ;; "Page already swapped in, but lives in a real page that might need to get bumped (e.g., for stack), so move it now")

                 (LET* ((NEWINDEX (\SELECTREALPAGE NIL T))
                        (NEWRPT (fetch RPTRBASE of NEWINDEX)))
                       (\MOVEREALPAGE RPINDEX RPTBASE NEWINDEX NEWRPT)
                       (replace (RPT EMPTY) of RPTBASE with T)
                                                             (* ; "Mark vacated RPT entry empty")
                       (SETQ RPTBASE NEWRPT]
             (replace (RPT LOCKED) of RPTBASE with T)
             (SETQ BASE (\ADDBASE BASE WORDSPERPAGE])

(\TEMPUNLOCKPAGES
  [LAMBDA (BASE NPAGES)                                  (* bvm%: "30-Jul-85 16:58")

    (* ;; "Unlocks pages that were locked by \TEMPLOCKPAGES.  This function must be locked because it manipulates the page table")

    (while (IGREATERP NPAGES 0) bind (VP _ (fetch (POINTER PAGE#) of BASE))
                                          RPTR
       do (UNINTERRUPTABLY
                  (\TOUCHPAGE BASE)                          (* ; 
         "Touch page in case not resident.  Should only happen if page wasn't locked to begin with")
                  (COND
                     ((AND (NEQ (SETQ RPTR (\READRP VP))
                                0)
                           (EQ [fetch (RPT VP) of (SETQ RPTR (fetch RPTRBASE
                                                                        of (RPTFROMRP RPTR]
                               VP))
                      (COND
                         ([AND DOLOCKCHECKS (EQ (LRSH VP 8)
                                                (CONSTANT (\HILOC \PAGEMAP]
                          (\MP.ERROR \MP.UNLOCKINGMAP "Attempt to unlock map page" VP)))
                      (replace (RPT LOCKED) of RPTR with NIL))
                     (T (HELP "Page table changed out from under me!" VP))))
             (add VP 1)
             (add NPAGES -1)
             (SETQ BASE (\ADDBASE BASE WORDSPERPAGE])

(\UNLOCKPAGES
  [LAMBDA (BASE NPAGES)                                  (* bvm%: "30-Jul-85 16:58")

(* ;;; "Unlocks NPAGES virtual pages from BASE onward")

    (UNINTERRUPTABLY
        (for I from 0 to (SUB1 NPAGES) bind (VP _ (fetch (POINTER PAGE#)
                                                                     of BASE))
                                                         MASK LOCKBASE
           do (COND
                     ((fetch (VP INVALID) of VP)
                      (\INVALIDVP VP))
                     ((NEQ 0 (LOGAND (SETQ MASK (.LOCKEDVPMASK. VP))
                                    (\GETBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP))
                                           0)))              (* ; 
                                                    "Yes, page was locked, so turn the bit off now")
                      (COND
                         ([AND DOLOCKCHECKS (EQ (LRSH VP 8)
                                                (CONSTANT (\HILOC \PAGEMAP]
                          (\MP.ERROR \MP.UNLOCKINGMAP "Attempt to unlock map page" VP)))
                      (\PUTBASE LOCKBASE 0 (LOGXOR MASK (\GETBASE LOCKBASE 0)))
                                                             (* ; 
                                                      "Update pagemap, then update real page table")
                      (replace (RPT LOCKED) of (fetch RPTRBASE of (RPTFROMRP
                                                                                   (\READRP VP)))
                         with NIL)))
                 (add VP 1)))])
)



(* ; "Writing out the vmem")

(DEFINEQ

(\FLUSHVM
  [LAMBDA (MAIKO.SYSOUTFILE)                            (* ; "Edited  6-Jan-89 19:23 by Hayata")

    (* ;; "Writes out all dirty pages to vmem, making it consistent.  Returns NIL now, T if Bcpl starts up the vmem")

    (COND
       ((\FLUSHVMOK?)
        (COND
           [(EQ \MACHINETYPE \MAIKO)
            (PROMPTPRINT "Saving sysout, taking mouse down.")

            (* ;; "check free space.")

            (\MAIKO.CHECKFREESPACE MAIKO.SYSOUTFILE)
            (UNINTERRUPTABLY
                (PROG NIL
                      (SELECTQ (\MISCAPPLY* (FUNCTION \DOFLUSHVM)
                                      MAIKO.SYSOUTFILE)
                          (NIL (SETQ \DIRTYPAGEHINT 32767)
                               (RETURN NIL))
                          (1 (ERROR "Can not find sysout file"))
                          (2 (ERROR "FILE-SYSTEM-RESOURCES-EXCEEDED"))
                          (3 (ERROR "Can not open sysout file"))
                          (4 (ERROR "Can not seek sysout file"))
                          (5 (ERROR "Can not write sysout file"))
                          (6 (ERROR "Connection timed out"))
                          NIL)
                      (SETQ \DOFAULTINIT T)
                      (\CONTEXTSWITCH \FAULTFXP)
                      (for VAR in \SYSTEMCACHEVARS do (SET VAR NIL))
                      (RETURN T)))]
           (T (UNINTERRUPTABLY
                                                             (* ; 
                                                           "Write stuff out from a safe place")
                  (PROG1 (COND
                            ((\MISCAPPLY* (FUNCTION \DOFLUSHVM))
                                                             (* ; 
"Return from Bcpl startup.  Need to rebuild the context, since it was not written out consistently")
                             (SETQ \DOFAULTINIT T)

                             (* ;; "Tell pagefault handler to initialize itself.  Want the initialization to happen in Fault context to avoid stack overflow messiness")

                             (\CONTEXTSWITCH \FAULTFXP)
                             (for VAR in \SYSTEMCACHEVARS do (SET VAR NIL))
                             T))
                         (SETQ \DIRTYPAGEHINT 32767)))])

(\LOGOUT0
  [LAMBDA (FAST)                                      (* ; "Edited 18-Jul-88 04:14 by masinter")
    [COND
       ((OR (EQ (fetch MachineType of \InterfacePage)
                \DORADO)
            (EQ (fetch MachineType of \InterfacePage)
                \DOLPHIN))

        (* ;; "If we're running on a Dolphin or Dorado, we update the alto's clock.  Note that Dandelions and Daybreaks don't have alto clocks, so this wouldn't work on them")

        (\BLT (EMADDRESS \RTCSECONDS)
              (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
              (UNFOLD 3 WORDSPERCELL]
    (UNINTERRUPTABLY
        (OR (AND [OR (NOT FAST)
                     (AND (EQ FAST '?)
                          (NOT (.VMEM.CONSISTENTP.]
                 (\FLUSHVM))
            (SELECTC \MACHINETYPE
                (\DAYBREAK (\DoveMisc.BootButton))
                (SUBRCALL LISPFINISH FAST))))])

(\DOFLUSHVM
  [LAMBDA (MAIKO.SYSOUTFILE)                            (* ; "Edited  6-Jan-89 19:23 by Hayata")

(* ;;; "Write everything out in a resumable way.  Value is NIL if returned from directly, T if from saved state.  Always invoked via \MISCAPPLY*")

    (CHECK (NOT \INTERRUPTABLE))                             (* ; 
                               "NOTE: need stats gathering off in here.  Also avoid touching pages")
    (PROG ((IFPVP (fetch (POINTER PAGE#) of \InterfacePage))
           (SCRATCHBUF \EMUSWAPBUFFERS)
           IFPRPT)
          (replace (IFPAGE MISCSTACKRESULT) of \InterfacePage with T)
                                                             (* ; 
"This will make it look like we have returned from BCPL if caller gets control from the saved state")
          [COND
             ((OR (EQ \MACHINETYPE \DANDELION)
                  (EQ \MACHINETYPE \DAYBREAK))               (* ; 
                                   "Mark all active stack pages dirty, since the microcode doesn't")
              (for VP from \VP.STACK to (IPLUS \VP.STACK (fetch HIBYTE
                                                                        of (fetch EndOfStack
                                                                                  of 
                                                                                       \InterfacePage
                                                                                      )))
                 as RP from \RP.STACK do (\WRITEMAP VP RP (LOGOR \VMAP.REF \VMAP.DIRTY)))
                                                             (* ; 
                                                "Similarly, the GC table does not get marked dirty")
              (for VP from \VP.GCTABLE to (IPLUS \VP.GCTABLE (SUB1 \NP.GCTABLE))
                 as RP from \RP.GCTABLE do (\WRITEMAP VP RP (LOGOR \VMAP.REF \VMAP.DIRTY]
          [COND
             ((EQ \MACHINETYPE \MAIKO)

              (* ;; "update interface pge before writing out sysout")

              (replace (IFPAGE CurrentFXP) of \InterfacePage with (fetch (IFPAGE
                                                                                          MiscFXP)
                                                                                 of 
                                                                                       \InterfacePage
                                                                                     ))
              (RETURN (SUBRCALL VMEMSAVE MAIKO.SYSOUTFILE]
          [COND
             (\VMEM.PURE.LIMIT                               (* ; 
                                            "Maintaining file consistency: move high water mark up")
                    (COND
                       (VMEM.COMPRESS.FLG (\DOCOMPRESSVMEM)))
                    (SETQ \VMEM.PURE.LIMIT (fetch (IFPAGE NActivePages) of \InterfacePage]
          (COND
             ((.VMEM.CONSISTENTP.)
              (replace (IFPAGE Key) of \InterfacePage with (LOGNOT16 \IFPValidKey))
                                                             (* ; 
                                                 "Invalidate vmem and write out the Interface page")
              (\TRANSFERPAGE IFPVP \FirstVmemBlock (RPTFROMRP (\READRP IFPVP))
                     T NIL)))
          (SETQ IFPRPT (RPTFROMRP (\READRP IFPVP)))
          (for RPTINDEX from 1 to (SUB1 \RPTSIZE) do (\FLUSHPAGE RPTINDEX T)
             unless (EQ RPTINDEX IFPRPT))
          (replace (IFPAGE Key) of \InterfacePage with \IFPValidKey)
          (\BLT SCRATCHBUF \InterfacePage WORDSPERPAGE)      (* ; 
                              "Make its current fx point at user context, i.e.  the \FLUSHVM frame")
          (replace (IFPAGE CurrentFXP) of SCRATCHBUF with (fetch (IFPAGE MiscFXP)
                                                                         of \InterfacePage))
          (\ACTONVMEMFILE (\LOOKUPPAGEMAP IFPVP)
                 SCRATCHBUF 1 T)                             (* ; 
                                                           "Write the page out from a safe place")
          (RETURN NIL])

(\RELEASEWORKINGSET
  [LAMBDA NIL                                            (* bvm%: "29-Nov-84 10:56")
    (COND
       ((\FLUSHVM)                                       (* ; "Returning from Lisp startup")
        T)
       (T                                                    (* ; "Unmap any unlocked page")
          (for RPTINDEX from 1 to (SUB1 \RPTSIZE) bind RPTR
             when (AND (fetch (RPT OCCUPIED) of (SETQ RPTR (fetch RPTRBASE
                                                                          of RPTINDEX)))
                           (NOT (fetch (RPT LOCKED) of RPTR)))
             do (\WRITEMAP (fetch (RPT VP) of RPTR)
                           (RPFROMRPT RPTINDEX)
                           \VMAP.VACANT)
                   (replace (RPT EMPTY) of RPTR with T])

(\WRITEDIRTYPAGE
  [LAMBDA (MINDIRTY)                                     (* bvm%: "13-Aug-85 17:51")
    (COND
       ((OR (NOT (.VMEM.CONSISTENTP.))
            (AND \VMEM.PURE.LIMIT (NEQ \VMEM.PURE.LIMIT -1)
                 (NOT \VMEM.FULL.STATE)))
        (PROG ((RPTR (OR \LASTDIRTYSCANPTR \REALPAGETABLE))
               (NUMDIRTY (OR \LASTDIRTYCNT 0))
               (CNT \MAXDIRTYSCANCOUNT)
               RP FP FLAGS)
              [COND
                 ((AND (NULL \LASTDIRTYSCANPTR)
                       (IGREATERP (IPLUS (add \DIRTYPAGECOUNTER 1)
                                         \PAGEFAULTCOUNTER)
                              \UPDATECHAINFREQ))             (* ; 
                                                  "Take this time to update the page chain instead")
                  (RETURN (UNINTERRUPTABLY
                              (\MISCAPPLY* (FUNCTION \UPDATECHAIN)))]
              (OR MINDIRTY (SETQ MINDIRTY 1))
          LP  [COND
                 [(EQ (SETQ RP (fetch (RPT NEXTRP) of RPTR))
                      \PAGETABLESTOPFLG)                     (* ; 
                                  "Hit end of chain.  Write out what we found if enough were dirty")
                  (COND
                     ((AND (IGEQ NUMDIRTY MINDIRTY)
                           (NEQ NUMDIRTY 0)
                           (SETQ RP \LASTDIRTYFOUND))
                      (GO GOTPAGE))
                     (T (SETQ \LASTDIRTYSCANPTR (SETQ \LASTDIRTYCNT (SETQ \LASTDIRTYFOUND NIL)))
                        [COND
                           ((AND (NEQ NUMDIRTY 0)
                                 (ILESSP \DIRTYSEEKMAX (LRSH MAX.SMALL.INTEGER 1)))
                                                             (* ; 
                                     "Failed because page not close enough, so widen the tolerance")
                            (SETQ \DIRTYSEEKMAX (LLSH \DIRTYSEEKMAX 1]
                        (RETURN]
                 ((fetch (RPT EMPTY) of (SETQ RPTR (fetch RPTRBASE of RP)))
                                                             (* ; 
                                              "Page is empty.  Should never happen if key is valid")
                  (RETURN))
                 ((NOT (fetch (RPT LOCKED) of RPTR)) (* ; 
            "Don't bother writing out locked pages, since they don't help us in our swapping quest")
                  (SETQ FLAGS (\READFLAGS (fetch (RPT VP) of RPTR)))
                  (COND
                     ((NOT (fetch (VMEMFLAGS DIRTY) of FLAGS))
                                                             (* ; "Page not dirty;  skip")
                      )
                     [(PROGN (SETQ FP (fetch (RPT FILEPAGE) of RPTR))
                             (IGREATERP (IABS (IDIFFERENCE (COND
                                                              ((AND \VMEM.PURE.LIMIT (ILESSP FP 
                                                                                     \VMEM.PURE.LIMIT
                                                                                            ))
                                                             (* ; 
                                                 "We'd have to write page to a new place, not here")
                                                               (fetch (IFPAGE NActivePages)
                                                                  of \InterfacePage))
                                                              (T FP))
                                                     \LASTACCESSEDVMEMPAGE))
                                    \DIRTYSEEKMAX))          (* ; 
                                                           "Page too far away, don't write it")
                      (COND
                         ((fetch (VMEMFLAGS REFERENCED) of FLAGS)
                                                             (* ; "but still count it")
                          (add NUMDIRTY 1]
                     ((IGREATERP FP \LASTVMEMFILEPAGE)       (* ; "Can't write it")
                      )
                     ((fetch (VMEMFLAGS REFERENCED) of FLAGS)
                                                             (* ; 
                           "Page dirty but referenced.  Note it, but keep looking for a better one")
                      (COND
                         ((EQ NUMDIRTY 0)
                          (SETQ \LASTDIRTYFOUND RP)))
                      (add NUMDIRTY 1))
                     (T                                      (* ; "Dirty, not referenced: do it")
                        (GO GOTPAGE]
              (COND
                 ((EQ (add CNT -1)
                      0)                                     (* ; 
                                                    "Scanned for long enough;  don't lock user out")
                  (SETQ \LASTDIRTYSCANPTR RPTR)
                  (SETQ \LASTDIRTYCNT NUMDIRTY)
                  (RETURN)))
              (GO LP)
          GOTPAGE
              (UNINTERRUPTABLY
                  (SETQ \LASTDIRTYSCANPTR (SETQ RPTR (fetch RPTRBASE of RP)))
                                                             (* ; "Keep traveling pointer")
                  (SETQ \LASTDIRTYCNT (SETQ \LASTDIRTYFOUND NIL))
                  (COND
                     ((ILEQ (IABS (IDIFFERENCE (fetch (RPT FILEPAGE) of RPTR)
                                         \LASTACCESSEDVMEMPAGE))
                            \DIRTYSEEKMAX)                   (* ; 
                        "Could fail if swapping since the selection has moved the disk arm too far")
                      (\MISCAPPLY* (FUNCTION \WRITEDIRTYPAGE1)
                             RP RPTR)))
                  (SETQ \DIRTYSEEKMAX \MAXSHORTSEEK))
              (RETURN T])

(\WRITEDIRTYPAGE1
  [LAMBDA (RP RPTR)                                      (* bvm%: "13-Aug-85 16:41")
                                                             (* ; 
                           "Write out buffer RP.  This fn is locked and called in the misc context")
    (COND
       ([AND (NOT (fetch (RPT LOCKED) of RPTR))
             (fetch (VMEMFLAGS DIRTY) of (\READFLAGS (fetch (RPT VP) of RPTR]
                                                             (* ; 
               "Verify that the page is still a candidate, so previous loop could be interruptable")
        (\FLUSHPAGE RP)
        (COND
           (\NEWVMEMPAGEADDED (\ASSURE.FPTOVP.PAGE])

(\COUNTREALPAGES
  [LAMBDA (TYPE)                                         (* bvm%: "18-Dec-84 15:31")
    (SELECTQ TYPE
        ((DIRTY REF) 
             [PROG [(FLAGBITS (COND
                                 ((EQ TYPE 'DIRTY)
                                  \VMAP.DIRTY)
                                 (T \VMAP.REF]
                   (RETURN (NPAGESMACRO (NEQ (LOGAND (\READFLAGS VP)
                                                    FLAGBITS)
                                             0])
        (LOCKED (NPAGESMACRO (fetch (RPT LOCKED) of RPTR)))
        (OCCUPIED (NPAGESMACRO T))
        (\ILLEGAL.ARG TYPE])
)



(* ; "VMEM.PURE.STATE hack")

(DEFINEQ

(\DOCOMPRESSVMEM
  [LAMBDA NIL                                            (* bvm%: " 7-Apr-84 17:53")

(* ;;; "Called underneath \DOFLUSHVM to write the pages above the high water mark back to the places vacated below that mark")

    (PROG ((EMPTYFP (DLFPFROMRP \RP.GCTABLE))
           (LASTFP (fetch NActivePages of \InterfacePage))
           (OLDVIW \VMEM.INHIBIT.WRITE)
           VP)
          [COND
             ((NULL OLDVIW)

              (* ;; "Encourage \SELECTREALPAGE to select only `old' file pages for displacement, so that we don't needlessly write the same page twice")

              (SETQ \VMEM.INHIBIT.WRITE 'NEW]
      LP  (COND
             ((IGEQ EMPTYFP LASTFP)
              (SETQ \VMEM.INHIBIT.WRITE OLDVIW)
              (RETURN)))
          [COND
             ((EQ (\GETBASE \FPTOVP EMPTYFP)
                  \NO.VMEM.PAGE)
              (while (EQ (SETQ VP (\GETBASE \FPTOVP LASTFP))
                             \NO.VMEM.PAGE) do (SETQ LASTFP (SUB1 LASTFP)))
              (\MOVEVMEMFILEPAGE VP LASTFP EMPTYFP)
              (replace NActivePages of \InterfacePage with (SETQ LASTFP (SUB1 LASTFP]
          (add EMPTYFP 1)
          (GO LP])

(VMEM.PURE.STATE
  [LAMBDA FLG                                            (* bvm%: " 7-Apr-84 16:59")
    (PROG1 (NOT (NULL \VMEM.PURE.LIMIT))
        [COND
           ((IGREATERP FLG 0)

            (* ;; "Set \VMEM.PURE.LIMIT appropriately.  If turning on, and it wasn't on before, set it to -1 so that it takes effect only at the next FLUSHVM")

            (SETQ \VMEM.PURE.LIMIT (AND (ARG FLG 1)
                                        (OR \VMEM.PURE.LIMIT (SETQ \VMEM.PURE.LIMIT -1])])
)



(* ;; 
"Handling the backing store getting too full--keep running, but if we overflow, we can never \FLUSHVM because there is no place to write some pages"
)

(DEFINEQ

(32MBADDRESSABLE
  [LAMBDA NIL                                         (* ; "Edited  2-May-88 22:03 by MASINTER")
    (SELECTC \MACHINETYPE
        (\DORADO T)
        (\DOLPHIN NIL)
        (\DAYBREAK T)
        (NEQ 0 (fetch (IFPAGE DL24BitAddressable) of \InterfacePage])

(\SET.VMEM.FULL.STATE
  [LAMBDA NIL                                            (* bvm%: "13-Feb-85 20:12")
                                                             (* ; 
                 "We are running out of vmem, try to extend file.  Do this at next convenient time")
    (COND
       ((NOT \VMEM.FULL.STATE)                               (* ; "Get an interrupt to handle this")
        (replace VMEMFULL of \INTERRUPTSTATE with T)
        (SETQ \PENDINGINTERRUPT T)))
    (SETQ \VMEM.FULL.STATE (COND
                              ((ILESSP (fetch (IFPAGE NActivePages) of \InterfacePage)
                                      \LASTVMEMFILEPAGE)     (* ; 
                                               "Not completely full, allow normal things to happen")
                               0)
                              ((.VMEM.CONSISTENTP.)
                               T)
                              (T 'DIRTY])

(\SET.LASTVMEMFILEPAGE
  [LAMBDA (N)                                            (* ; "Edited  6-Apr-87 14:09 by bvm:")

    (* ;; "Called by disk routines when they discover how long the physical vmem is.  Currently only used by Dove.")

    (COND
       ((IGREATERP (fetch (IFPAGE NActivePages) of \InterfacePage)
               (IDIFFERENCE (SETQ \LASTVMEMFILEPAGE N)
                      \GUARDVMEMFULL))                       (* ; "Vmem getting full!")
        (\SET.VMEM.FULL.STATE))
       (T                                                    (* ; 
                                          "Vmem ok now (was earlier set to full for safety's sake)")
          (SETQ \VMEM.FULL.STATE NIL)))
    N])

(\DOVMEMFULLINTERRUPT
  [LAMBDA NIL                                            (* ; "Edited 21-Oct-87 13:54 by bvm:")

(* ;;; "Called while interruptable when vmem is full or nearly so.  Tries to extend vmem file, or gives error if it can't")

    (COND
       (\EXTENDINGVMEMFILE 

              (* ;; "Another interrupt happened while we are extending file.  Don't try to do this one twice, but repost the interrupt in the hopes that it will happen after vmem extension is finished")

              (SETQ \PENDINGINTERRUPT T))
       (T (RESETVARS ((\EXTENDINGVMEMFILE T))

           (* ;; "Used to have code here that tried to extend the vmem file, but even on those that support extension it's flaky, and rarely what you want--people allocate the vmem file to the desired size in the first place, don't want it extended further.")

                     (PROG ((HELPFLAG 'BREAK!))
                           (replace VMEMFULL of \INTERRUPTSTATE with NIL)
                                                             (* ; 
             "Very slight chance of losing the break if ^E right here.  Don't know how to fix this")
                           (CL:CERROR "Resume the interrupted computation"
                                  (CONCAT "Your virtual memory backing file is "
                                         (COND
                                            ((>= (fetch (IFPAGE NActivePages) of 
                                                                                       \InterfacePage
                                                        )
                                                 \LASTVMEMFILEPAGE)
                                             "complete")
                                            (T "near"))
                                         "ly full.
Save your work & reload a.s.a.p."])

(\FLUSHVMOK?
  [LAMBDA (TYPE NOERROR)                                 (* bvm%: " 7-Sep-85 10:48")

(* ;;; "Called before any attempt to do a \FLUSHVM to make sure it's ok")

    (LET [(MSG (COND
                  ((SELECTQ \VMEM.FULL.STATE
                       ((T DIRTY) 
                            T)
                       NIL)
                   "-- virtual memory backing file too small")
                  ((AND \VMEM.PURE.LIMIT (NEQ \VMEM.PURE.LIMIT -1)
                        (NOT VMEM.COMPRESS.FLG))
                   " while VMEM.PURE.STATE is on."]
         (COND
            ((NOT MSG)
             T)
            (T [COND
                  ((NOT NOERROR)
                   (ERROR [CONCAT "Can't " (OR TYPE (SETQ TYPE 'LOGOUT]
                          MSG
                          (COND
                             ((EQ TYPE 'LOGOUT)
                              "
You may (LOGOUT T), which quits without saving state.")
                             (T ""]
               NIL])
)

(RPAQ? \UPDATECHAINFREQ 100)

(RPAQ? \PAGEFAULTCOUNTER 0)

(RPAQ? \DIRTYPAGECOUNTER 0)

(RPAQ? \DIRTYPAGEHINT 0)

(RPAQ? \LASTACCESSEDVMEMPAGE 0)

(RPAQ? \MAXSHORTSEEK 1000)

(RPAQ? \MINSHORTSEEK 20)

(RPAQ? \MAXCLEANPROBES 20)

(RPAQ? \VMEM.INHIBIT.WRITE )

(RPAQ? \VMEM.PURE.LIMIT )

(RPAQ? \VMEM.FULL.STATE )

(RPAQ? \GUARDVMEMFULL 500)

(RPAQ? VMEM.COMPRESS.FLG )

(RPAQ? \DOFAULTINIT 0)

(RPAQ? \VMEMACCESSFN )

(RPAQ? \SYSTEMCACHEVARS )

(RPAQ? \MAXSWAPBUFFERS 1)

(RPAQ? \EXTENDINGVMEMFILE )

(RPAQ? \MaxScreenPage 0)

(RPAQ? \NEWVMEMPAGEADDED )

(RPAQ? \LASTDIRTYCNT )

(RPAQ? \LASTDIRTYFOUND )

(RPAQ? \LASTDIRTYSCANPTR )

(RPAQ? \DIRTYSEEKMAX 50)



(* ; "Errors signaled in the maintenance panel")

(DEFINEQ

(\MP.ERROR
  [LAMBDA (CODE STRING ARG1 ARG2)                        (* mpl "20-Jun-85 11:09")
    (COND
       ((OR (EQ \MACHINETYPE \DANDELION)
            (EQ \MACHINETYPE \DAYBREAK))
        ((OPCODES RAID)
         CODE))
       (T (RAID STRING ARG1 ARG2])
)



(* ; "Debugging code.  Some of this also runs renamed for extra TeleRaid help")

(DEFINEQ

(\ACTONVMEMFILE
  [LAMBDA (FILEPAGE BUFFER NPAGES WRITEFLAG)             (* MPL "22-Jun-85 20:18")
    (COND
       ((EQ \MACHINETYPE \DANDELION)
        (\DL.ACTONVMEMFILE FILEPAGE BUFFER NPAGES WRITEFLAG))
       ((EQ \MACHINETYPE \DAYBREAK)
        (\DOVE.ACTONVMEMFILE FILEPAGE BUFFER NPAGES WRITEFLAG))
       (T (\M44ACTONVMEMFILE FILEPAGE BUFFER NPAGES WRITEFLAG])

(\SHOWPAGETABLE
  [LAMBDA (MODE FILE)                                    (* bvm%: "12-Jul-86 16:55")
    (PROG ((*PRINT-BASE* 8)
           (OUTSTREAM (GETSTREAM FILE 'OUTPUT))
           (RPTR \REALPAGETABLE)
           (RP 0)
           FLAGS VP STATE FIRSTONE LASTONE)
          (printout OUTSTREAM "     RP      VP           FilePage  Status" T)
          (until (SELECTQ MODE
                         (CHAIN (EQ (SETQ RP (fetch (RPT NEXTRP) of RPTR))
                                    \PAGETABLESTOPFLG))
                         (NIL (add RP 1)
                              (IGEQ RP \RPTSIZE))
                         (\ILLEGAL.ARG MODE))
             do (SETQ RPTR (fetch RPTRBASE of RP))
                   (SETQ VP (fetch (RPT VP) of RPTR))
                   (COND
                      ((AND (NULL MODE)
                            (EQ VP STATE))
                       (SETQ LASTONE RP))
                      (T (COND
                            (LASTONE (printout OUTSTREAM "ditto thru " LASTONE T)
                                   (SETQ LASTONE NIL)))
                         (SETQ FIRSTONE RP)
                         (SETQ STATE VP)
                         (printout OUTSTREAM |.I7.8| (RPFROMRPT RP))
                         [COND
                            ((fetch (RPT EMPTY) of RPTR)
                             (PRIN1 " Empty" OUTSTREAM))
                            ((NOT (fetch (RPT OCCUPIED) of RPTR))
                             (PRIN1 " Unavailable" OUTSTREAM))
                            (T (printout OUTSTREAM |.I8.8| VP %,)
                               (\PRINTVP VP OUTSTREAM)
                               (printout OUTSTREAM 28 |.I6.8| (fetch (RPT FILEPAGE) of RPTR)
                                      %,,)
                               (COND
                                  ((fetch (RPT LOCKED) of RPTR)
                                   (COND
                                      ((NOT (\LOCKEDPAGEP VP))
                                                             (* ; "not permanently locked")
                                       (PRIN1 "Temp" OUTSTREAM)))
                                   (PRIN1 "Locked " OUTSTREAM)))
                               (UNLESSRDSYS (PROGN (COND
                                                      ((fetch (VMEMFLAGS REFERENCED)
                                                          of (SETQ FLAGS (\READFLAGS VP)))
                                                       (PRIN1 "Ref " OUTSTREAM)))
                                                   (COND
                                                      ((fetch (VMEMFLAGS DIRTY) of FLAGS)
                                                       (PRIN1 "Dirty" OUTSTREAM]
                         (TERPRI OUTSTREAM])

(CHECKPAGEMAP
  [LAMBDA NIL                                            (* bvm%: "12-Jul-86 16:56")
    (LET ((*PRINT-BASE* 8)
          (NUMOCCUPIED 0)
          (NUMLOCKED 0)
          (CHAINOCCUPIED 0)
          (CHAINLOCKED 0)
          RPTR FPBASE FP VP RP)
         (CHECKFPTOVP)
         [for RPTINDEX from 1 to (SUB1 \RPTSIZE)
            when (fetch (RPT OCCUPIED) of (SETQ RPTR (fetch RPTRBASE of RPTINDEX)
                                                       ))
            do (add NUMOCCUPIED 1)
                  (SETQ VP (fetch (RPT VP) of RPTR))
                  (SETQ FP (fetch (RPT FILEPAGE) of RPTR))
                  (COND
                     ((CHECKFPTOVP1 FP VP RPTINDEX))
                     ([NEQ VP (fetch FPVIRTUALPAGE of (SETQ FPBASE (\ADDBASE \FPTOVP FP]
                      (printout T "RPT for RP " (RPFROMRPT RPTINDEX)
                             " says VP ")
                      (\PRINTVP VP T)
                      (printout T " lives in FP " FP "; but FP Map says that FP contains ")
                      (\PRINTVP (fetch FPVIRTUALPAGE of FPBASE)
                             T)
                      (printout T T))
                     ((\LOCKEDPAGEP VP)
                      (add NUMLOCKED 1)
                      (COND
                         ((NOT (fetch (RPT LOCKED) of RPTR))
                          (printout T "VP " VP ", living in RP " (RPFROMRPT RPTINDEX)
                                 " should be locked but isn't." T))
                         ((IGREATERP FP (DLRPFROMFP (fetch (IFPAGE LastLockedFilePage)
                                                       of \InterfacePage)))
                          (printout T "VP " VP " is locked, but living in FP " FP 
                                 ", which is not in the locked page area" T]
         (PROGN (SETQ RPTR \REALPAGETABLE)                   (* ; "Check pagetable chain")
                [while (NEQ (SETQ RP (fetch (RPT NEXTRP) of RPTR))
                                \PAGETABLESTOPFLG) when (fetch (RPT OCCUPIED)
                                                               of (SETQ RPTR
                                                                       (fetch RPTRBASE
                                                                          of RP)))
                   do (add CHAINOCCUPIED 1)
                         (COND
                            ((fetch (RPT LOCKED) of RPTR)
                             (add CHAINLOCKED 1]
                (COND
                   ((ILESSP CHAINOCCUPIED NUMOCCUPIED)
                    (printout T NUMOCCUPIED " occupied pages, but only " CHAINOCCUPIED 
                           " are on page chain.  " NUMLOCKED " pages are permanently locked; " 
                           CHAINLOCKED " pages on chain are locked somehow." T])

(CHECKFPTOVP
  [LAMBDA NIL                                            (* bvm%: "10-Dec-84 12:39")
    (for FP from 1 to (fetch NActivePages of \InterfacePage)
       as (FPBASE _ (\ADDBASE \FPTOVP 1)) by (\ADDBASE FPBASE 1)
       when (fetch FPOCCUPIED of FPBASE) do (CHECKFPTOVP1 FP
                                                                   (fetch FPVIRTUALPAGE
                                                                      of FPBASE])

(CHECKFPTOVP1
  [LAMBDA (FP VP RPTINDEX)                               (* bvm%: "10-Dec-84 12:36")
    (PROG ((FP2 (\LOOKUPPAGEMAP VP)))
          (RETURN (COND
                     ((NEQ FP2 FP)
                      (COND
                         ((UNLESSRDSYS RPTINDEX)
                          (printout T "RPT for RP " (RPFROMRPT RPTINDEX)))
                         (T (printout T "FP map")))
                      (printout T " says FP " FP " contains VP ")
                      (\PRINTVP VP T)
                      (printout T "; but PageMap says that page is in FP " FP2 T)
                      T])

(\PRINTFPTOVP
  [LAMBDA (FIRSTPAGE NWORDS TYPEFLG STREAM VPRAWFLG)     (* bvm%: "24-Sep-86 11:44")
    (SETQ STREAM (GETSTREAM STREAM 'OUTPUT))
    (OR FIRSTPAGE (SETQ FIRSTPAGE 1))
    (OR NWORDS (SETQ NWORDS (fetch (IFPAGE NActivePages) of \InterfacePage)))
    (LET ((BASE (\ADDBASE \FPTOVP (SUB1 FIRSTPAGE)))
          (*PRINT-BASE* 8)
          (LASTVP -2)
          (NEXTFP (SUB1 FIRSTPAGE))
          FIRSTFP FIRSTVP NEXTVP LOCKEDP TYPE NEXTLOCKED NEXTTYPE)
         (while (IGEQ NWORDS 0)
            do (add NEXTFP 1)
                  [COND
                     ((EQ NWORDS 0)
                      (SETQ NEXTVP -1))
                     ((NEQ (SETQ NEXTVP (\GETBASE (SETQ BASE (\ADDBASE BASE 1))
                                               0))
                           \NO.VMEM.PAGE)
                      (SETQ NEXTLOCKED (\LOCKEDPAGEP NEXTVP))
                      (if TYPEFLG
                          then (SETQ NEXTTYPE (TYPENAME (create POINTER
                                                                   PAGE# _ NEXTVP)))
                                (if (NULL NEXTTYPE)
                                    then (SETQ NEXTTYPE (SELECTC (LRSH NEXTVP 8)
                                                                ((LIST \PNAME.HI (CL:1+ \PNAME.HI)) 
                                                                     "Pnames")
                                                                ((LIST \DEF.HI (CL:1+ \DEF.HI)) 
                                                                     "Definitions")
                                                                ((LIST \VAL.HI (CL:1+ \VAL.HI)) 
                                                                     "Value cells")
                                                                ((LIST \PLIST.HI (CL:1+ \PLIST.HI)) 
                                                                     "Property lists")
                                                                ((\HILOC \FPTOVP) 
                                                                     "\FPTOVP")
                                                                (\STACKHI "Stack")
                                                                ((\HILOC \HTMAIN) 
                                                                     "GC Main table")
                                                                ((\HILOC \HTOVERFLOW) 
                                                                     "GC Overflow table")
                                                                NIL]
                  [COND
                     ([COND
                         ((EQ NEXTVP \NO.VMEM.PAGE)
                          (NEQ LASTVP \NO.VMEM.PAGE))
                         (T (OR (NEQ NEXTVP (ADD1 LASTVP))
                                (NEQ NEXTLOCKED LOCKEDP)
                                (NEQ TYPE NEXTTYPE]
                      [COND
                         ((IGEQ LASTVP 0)
                          (COND
                             (FIRSTFP (printout STREAM FIRSTFP "-")))
                          (printout STREAM (SUB1 NEXTFP)
                                 12)
                          (COND
                             ((EQ LASTVP \NO.VMEM.PAGE)
                              (printout STREAM "empty"))
                             (T (COND
                                   (FIRSTFP (if VPRAWFLG
                                                then (PRIN1 FIRSTVP STREAM)
                                              else (\PRINTVP FIRSTVP STREAM))
                                          (PRIN1 "-" STREAM)))
                                (if VPRAWFLG
                                    then (PRIN1 LASTVP STREAM)
                                  else (\PRINTVP LASTVP STREAM))
                                (COND
                                   (LOCKEDP (PRIN1 '* STREAM)))
                                (if TYPE
                                    then (printout STREAM 32 TYPE]
                      (SETQ FIRSTFP)
                      (TERPRI STREAM)
                      (SETQ FIRSTVP NEXTVP))
                     (T                                      (* ; "in a run")
                        (OR FIRSTFP (SETQ FIRSTFP (SUB1 NEXTFP]
                  (SETQ LASTVP NEXTVP)
                  (SETQ LOCKEDP NEXTLOCKED)
                  (SETQ TYPE NEXTTYPE)
                  (add NWORDS -1])

(\PRINTVP
  [LAMBDA (VP STREAM)                                    (* bvm%: "28-MAR-83 12:40")
    (printout STREAM "{" (LRSH VP 8)
           ","
           (LOGAND VP 255)
           "}"])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \ACTONVMEMFILE MACRO ((X . Y)
                                        (SPREADAPPLY* \VMEMACCESSFN X . Y)))

(PUTPROPS .VMEM.CONSISTENTP. MACRO (NIL (EQ (fetch (IFPAGE Key) of \InterfacePage)
                                                    \IFPValidKey)))

(PUTPROPS .LOCKABLERP. MACRO [(RP)
                                      (OR (NEQ (FOLDLO RP PAGESPERSEGMENT)
                                               (FOLDLO \RP.STACK PAGESPERSEGMENT))
                                          (NOT (OR (EQ \MACHINETYPE \DANDELION)
                                                   (EQ \MACHINETYPE \DAYBREAK])
)




(* ; "Virtual page flags")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \VMAP.DIRTY 10000Q)

(RPAQQ \VMAP.CLEAN 0)

(RPAQQ \VMAP.REF 100000Q)

(RPAQQ \VMAP.VACANT 30000Q)

(RPAQQ \VMAP.FLAGS 170000Q)

(RPAQQ \VMAP.NOTFLAGS 7777Q)


(CONSTANTS \VMAP.DIRTY \VMAP.CLEAN \VMAP.REF \VMAP.VACANT \VMAP.FLAGS \VMAP.NOTFLAGS)
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS VMEMFLAGS ((VACANT (EQ (LOGAND DATUM \VMAP.VACANT)
                                      \VMAP.VACANT))
                          (DIRTY (NEQ (LOGAND DATUM \VMAP.DIRTY)
                                      0))
                          (REFERENCED (NEQ (LOGAND DATUM \VMAP.REF)
                                           0))))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS LOGNOT16 MACRO ((X)
                                  (LOGXOR X 177777Q)))
)




(* ; "RPT constants")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \RPT.EMPTY 177776Q)

(RPAQQ \RPT.UNAVAILABLE 177777Q)

(RPAQQ \PAGETABLESTOPFLG 0)

(RPAQQ \RPTENTRYLENGTH 3)


(CONSTANTS \RPT.EMPTY \RPT.UNAVAILABLE \PAGETABLESTOPFLG \RPTENTRYLENGTH)
)
(DECLARE%: EVAL@COMPILE

(BLOCKRECORD RPT ((LOCKED FLAG)
                      (NEXTRP BITS 17Q)
                      (VP WORD)
                      (FILEPAGE WORD))
                     (BLOCKRECORD RPT ((NIL BITS 20Q)
                                       (VPSEG BYTE)
                                       (VPPAGEINSEG BYTE)))
                     [ACCESSFNS RPT ([EMPTY (EQ (fetch (RPT VP) of DATUM)
                                                \RPT.EMPTY)
                                            (COND
                                               (NEWVALUE (replace (RPT VP) of DATUM
                                                            with \RPT.EMPTY))
                                               (T (ERROR "Invalid replace of RPT.EMPTY" DATUM]
                                     [UNAVAILABLE (EQ (fetch (RPT VP) of DATUM)
                                                      \RPT.UNAVAILABLE)
                                            (COND
                                               (NEWVALUE (replace (RPT VP) of DATUM
                                                            with \RPT.UNAVAILABLE))
                                               (T (ERROR "Invalid replace of RPT.UNAVAILABLE" DATUM]
                                     (OCCUPIED (ILESSP (fetch (RPT VP) of DATUM)
                                                      \RPT.EMPTY])

(ACCESSFNS RPT1 (RPTRBASE (\ADDBASE (\ADDBASE \REALPAGETABLE (LLSH DATUM 1))
                                     DATUM)))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS RPFROMRPT MACRO ((RPTINDEX)
                                   (IPLUS RPTINDEX \RPOFFSET)))

(PUTPROPS RPTFROMRP MACRO ((RP)
                                   (IDIFFERENCE RP \RPOFFSET)))

(PUTPROPS NPAGESMACRO MACRO ((FORM)
                                     (PROG ((RESULT 0)
                                            (CNTR \RPTSIZE)
                                            (RPTR \REALPAGETABLE)
                                            VP)
                                       LP  (COND
                                              ((NEQ (SETQ CNTR (SUB1 CNTR))
                                                    0)
                                               (SETQ RPTR (\ADDBASE RPTR \RPTENTRYLENGTH))
                                               (COND
                                                  ((AND (fetch (RPT OCCUPIED) of RPTR)
                                                        (PROGN (SETQ VP (fetch (RPT VP)
                                                                           of RPTR))
                                                               FORM))
                                                   (add RESULT 1)))
                                               (GO LP)))
                                           (RETURN RESULT))))
)




(* ; "Virtual to file pagemap")

(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAXFILEPAGE 177776Q)


(CONSTANTS \MAXFILEPAGE)
)

(* "END EXPORTED DEFINITIONS")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \EMPTYPMTENTRY 177777Q)


(CONSTANTS \EMPTYPMTENTRY)
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS VP ((PRIMARYKEY (LRSH DATUM 5))
                   (SECONDARYKEY (LOGAND DATUM 37Q))
                   (INVALID (PROGN NIL))))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS .PAGEMAPBASE. MACRO [OPENLAMBDA (VPAGE)
                                             (\ADDBASE \PAGEMAP (IPLUS (\GETBASE \PageMapTBL
                                                                              (fetch (VP 
                                                                                           PRIMARYKEY
                                                                                             )
                                                                                 of VPAGE))
                                                                       (fetch (VP SECONDARYKEY)
                                                                          of VPAGE])
)




(* ; "FP to VP stuff")

(DECLARE%: EVAL@COMPILE

(BLOCKRECORD FPTOVP ((FPVIRTUALPAGE FIXP))
                        [ACCESSFNS FPTOVP ((FPOCCUPIED (NEQ (\GETBASE DATUM 0)
                                                            \NO.VMEM.PAGE])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \NO.VMEM.PAGE 177777Q)


(CONSTANTS \NO.VMEM.PAGE)
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS DLRPFROMFP MACRO ((FP)
                                    (ADD1 FP)))

(PUTPROPS DLFPFROMRP MACRO ((RP)
                                    (SUB1 RP)))
)


(PUTPROPS \TOUCHPAGE DOPVAL (1 GETBASE.N 0))

(PUTPROPS TIMES3 DOPVAL (1 COPY LLSH1 IPLUS2))




(* ; "Locked page table")

(DECLARE%: EVAL@COMPILE 

(PUTPROPS .LOCKEDVPBASE. MACRO ((VP)
                                        (\ADDBASE \LOCKEDPAGETABLE (FOLDLO VP BITSPERWORD))))

(PUTPROPS .LOCKEDVPMASK. MACRO ((VP)
                                        (LLSH 1 (IMOD VP BITSPERWORD))))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAXDIRTYSCANCOUNT 144Q)

(RPAQQ \MINVMEMSPAREPAGES 144Q)

(RPAQQ \DLBUFFERPAGES 20Q)


(CONSTANTS \MAXDIRTYSCANCOUNT \MINVMEMSPAREPAGES \DLBUFFERPAGES)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ 2MBPAGES 10000Q)


(CONSTANTS 2MBPAGES)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \UPDATECHAINFREQ \REALPAGETABLE \RPTLAST \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE 
       \EMBUFVP \EMBUFRP \PAGEFAULTCOUNTER \LASTDIRTYCNT \LASTDIRTYFOUND \LASTDIRTYSCANPTR 
       \MACHINETYPE \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYSEEKMAX 
       \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE 
       \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP 
       \VMEMACCESSFN \SYSTEMCACHEVARS \LASTVMEMFILEPAGE \EXTENDINGVMEMFILE \MaxScreenPage 
       \NEWVMEMPAGEADDED)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \#SWAPBUFFERS \#EMUBUFFERS \#DISKBUFFERS \MAXSWAPBUFFERS \EMUSWAPBUFFERS \EMUBUFFERS 
       \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS RWMufMan DMACRO ((X)
                                   ((OPCODES 170Q 11Q)
                                    X)))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ DOLOCKCHECKS NIL)


(CONSTANTS (DOLOCKCHECKS NIL))
)
)



(* ;;; "MAKEINIT stuff")

(DEFINEQ

(ADDPME
  [LAMBDA (VP NEWPAGEOK)                                 (* bvm%: " 6-Dec-84 14:07")

    (* ;; "add an entry for VP to the PAGEMAP.  Called only under MAKEINIT")

    (PROG (PX PMP LOCKBASE)
          [COND
             ((IEQ (SETQ PMP (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)))
                   \EmptyPMTEntry)                           (* ; 
                                      "empty entries in the PageMapTBL have 177777q as their value")
              (COND
                 ((EVENP NEXTPM WORDSPERPAGE)                (* ; "must add a new page map page")
                  (SETQ PX (\ADDBASE \PAGEMAP NEXTPM))
                  (OR NEWPAGEOK (IGREATERP (PAGELOC PX)
                                       VP)
                      (HELP "page map needs new page after page map written out"))
                  (\NEWPAGE PX NIL T)))
              (\PUTBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)
                     (SETQ PMP NEXTPM))
              (SETQ NEXTPM (IPLUS NEXTPM \PMblockSize]
          (SETQ PX (IPLUS PMP (fetch (VP SECONDARYKEY) of VP)))
          (COND
             ((NEQ (\GETBASE \PAGEMAP PX)
                   0)
              (HELP "page already in pagemap" VP))
             (T (\PUTBASE \PAGEMAP PX NEXTVMEM)
                [COND
                   ((LOCKEDPAGEP VP)                         (* ; 
                                                           "Set lock bit in locked page table")
                    (\PUTBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP))
                           0
                           (LOGOR (.LOCKEDVPMASK. VP)
                                  (\GETBASE LOCKBASE 0]
                (SETQ NEXTVMEM (ADD1 NEXTVMEM])

(CHECKIFPAGE
  [LAMBDA NIL                                            (* mjs "19-Jul-84 13:24")
    (CHECKIF Key EQUAL \IFPValidKey "Interface page key"])

(DUMPINITPAGES
  [LAMBDA (CODEFIRSTPAGE CODENEXTPAGE VERSIONS)          (* bvm%: "14-Jan-85 12:51")
                                                             (* ; "called only under MAKEINIT")
    (ADDPME (PAGELOC \InterfacePage)
           T)                                                (* ; 
                                                        "THE INTERFACE PAGE MUST BE THE FIRST PAGE")
    (for I from CODEFIRSTPAGE to (SUB1 CODENEXTPAGE) do 
                                                             (* ; 
                    "add the pagemap entries for the pages which were written directly to the file")
                                                                       (ADDPME I T))
    (MAPPAGES 0 (ADD1 \MAXVMPAGE)
           (FUNCTION MAKEROOMFORPME))
    (MAPPAGES 0 (ADD1 \MAXVMPAGE)
           (FUNCTION ADDPME))
    (PROGN                                                   (* ; 
                     "set interface page locations --- stack pointers already set up IN SETUPSTACK")
           (replace (IFPAGE NxtPMAddr) of \InterfacePage with NEXTPM)
           (replace (IFPAGE NActivePages) of \InterfacePage with (SUB1 NEXTVMEM))
           (replace (IFPAGE NDirtyPages) of \InterfacePage with (SUB1 NEXTVMEM))
           (replace (IFPAGE filePnPMP0) of \InterfacePage with (\GETBASE \PAGEMAP 0))
           (replace (IFPAGE filePnPMT0) of \InterfacePage with (\GETBASE
                                                                            (.PAGEMAPBASE.
                                                                             (PAGELOC \PageMapTBL))
                                                                            0))
           [COND
              (VERSIONS (replace (IFPAGE LVersion) of \InterfacePage with (CAR VERSIONS))
                     (replace (IFPAGE MinBVersion) of \InterfacePage with (CADDR VERSIONS
                                                                                             ))
                     (replace (IFPAGE MinRVersion) of \InterfacePage with (CADR VERSIONS]
           (replace (IFPAGE Key) of \InterfacePage with \IFPValidKey))
    (MAPPAGES 0 (ADD1 \MAXVMPAGE)
           (FUNCTION DUMPVP))
    (ALLOCAL (PROG ((FILE (OUTPUT)))
                   [COND
                      ((NOT (RANDACCESSP FILE))              (* ; 
                                "SYSOUT file is sequential;  have to get it random access for this")
                       (OUTPUT (SETQ FILE (OPENFILE (CLOSEF FILE)
                                                 'BOTH]
                   (SETFILEPTR FILE MKI.Page0Byte)))
    (DUMPVP (PAGELOC \InterfacePage])

(MAKEROOMFORPME
  [LAMBDA (VP)                                           (* bvm%: "29-MAR-83 17:11")

    (* ;; 
 "make sure that the pagemap-page for page VP exists;  we later will want to add it to the pagemap")

    (COND
       ((IEQ (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP))
             \EmptyPMTEntry)                                 (* ; 
                                      "empty entries in the PageMapTBL have 177777q as their value")
        (COND
           ((EVENP NEXTPM WORDSPERPAGE)                      (* ; "must add a new page map page")
            (\NEWPAGE (\ADDBASE \PAGEMAP NEXTPM)
                   NIL T)))
        (\PUTBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)
               NEXTPM)
        (SETQ NEXTPM (IPLUS NEXTPM \PMblockSize])

(MAPPAGES
  [LAMBDA (BOT TOP FN)                        (* ; 
                                                "Edited  5-Nov-92 15:41 by sybalsky:mv:envos")

    (* ;; "Map thru all pages from BOT to TOP that exist, skipping the interface page, if it falls into that range.  Call FN on the page number.")

    (PROG ((VP BOT)
           (IVP (PAGELOC \InterfacePage)))
      LP  (COND
             ((AND (SETQ VP (MKI.NEXTPAGE VP))
                   (IGREATERP TOP VP))
              (COND
                 ((NOT (IEQ VP IVP))
                  (APPLY* FN VP)))
              (SETQ VP (ADD1 VP))
              (GO LP])

(READPAGEMAP
  [LAMBDA NIL                                            (* bvm%: "10-Dec-84 21:54")
                                                             (* ; 
                          "called only under READSYS -- reads in pagemap so that SETVMPTR can work")
    (PROG (D)
          (LOCAL (MAPVMPAGE (fetch (POINTER PAGE#) of \InterfacePage)
                        1))                                  (* ; "Install interface page by magic")
                                                             (* PROGN (SETQ FPSTART
                                                           (fetch (IFPAGE LastDominoFilePage) 
                                                           of \InterfacePage))
                                                           (SETQ NPAGES (fetch
                                                           (IFPAGE NActivePages) of 
                                                           \InterfacePage)) (* ;
                                                           "Note: have to do these fetches before the SETFILEPTR since they indirectly do SETFILEPTR themselves")
                                                           (SETFILEPTR VMEMFILE
                                                           (IPLUS (UNFOLD (SUB1
                                                           (fetch (IFPAGE FPTOVPStart) of 
                                                           \InterfacePage)) BYTESPERPAGE)
                                                           (UNFOLD FPSTART BYTESPERWORD)))
                                                           (for I from FPSTART to NPAGES bind 
                                                           VP when (NEQ (SETQ VP
                                                           (VBIN2)) \NO.VMEM.PAGE) do
                                                           (* ; "Read in all of FPTOVP")
                                                           (MAPVMPAGE VP (SUB1 I))))
          [LOCAL (MAPVMPAGE (PAGELOC \PAGEMAP)
                        (SUB1 (fetch (IFPAGE filePnPMP0) of \InterfacePage]
                                                             (* ; "map in first page of secondary page map, which is where all the secondary map pages themselves live")
          (LOCAL (SETVMPTR \PAGEMAP))
          (for I from 0 to (SUB1 (FOLDHI PAGESPERSEGMENT \PMblockSize)) as VP
             from (PAGELOC \PAGEMAP) by \PMblockSize do 
                                                             (* ; 
"Have to read all the addresses of secondary map pages themselves before we can read their contents")
                                                                   (READPAGEMAPBLOCK VP))
          (for J from 0 to (SUB1 \NumPMTpages) as FP
             from (SUB1 (fetch (IFPAGE filePnPMT0) of \InterfacePage))
             do                                          (* ; 
                                                          "read in all the primary map table pages")
                   (LOCAL (MAPVMPAGE (IPLUS (PAGELOC \PageMapTBL)
                                            J)
                                 FP)))
          (for I from 0 to (SUB1 (UNFOLD \NumPMTpages WORDSPERPAGE))
             do (COND
                       ((IEQ (SETQ D (GETBASE \PageMapTBL I))
                             \EmptyPMTEntry))
                       (T (LOCAL (SETVMPTR (ADDBASE \PAGEMAP D)))
                          (READPAGEMAPBLOCK (UNFOLD I \PMblockSize])

(READPAGEMAPBLOCK
  [LAMBDA (VP)                                           (* lmm " 4-MAY-82 21:12")
    (PROG ((B VP)
           P)
          (FRPTQ \PMblockSize [COND
                                 ((NEQ (SETQ P (VBIN2))
                                       0)
                                  (LOCAL (MAPVMPAGE B (SUB1 P]
                 (SETQ B (ADD1 B])

(SETUPPAGEMAP
  [LAMBDA NIL                                 (* ; 
                                                "Edited  5-Nov-92 16:03 by sybalsky:mv:envos")
                                                             (* ; 
                                             "called only from MAKEINIT to initialize the page map")
    (PROG NIL                                                (* ; "set up page map")
          (\NEWPAGE \PAGEMAP NIL T)                      (* ; 
                                                           "Create 1 page worth of real page table")
          (CREATEPAGES \PageMapTBL \NumPMTpages NIL T)       (* ; "And the segment table.")

     (* ;; "init PageMapTBL pages to 177777q:")

          (for I from 0 to (SUB1 (UNFOLD \NumPMTpages WORDSPERPAGE))
             do (\PUTBASE \PageMapTBL I \EmptyPMTEntry))
          (SETQ NEXTPM 0)
          (for I from 0 to (SUB1 (fetch (VP PRIMARYKEY) of \NumPageMapPages))
             bind (PAGEMAPKEY _ (fetch (VP PRIMARYKEY) of (PAGELOC \PAGEMAP)))
             do 

                   (* ;; "Assign pagemap pages to cover all pagemap pages, so that \DONEWPAGE can guarantee that when it needs to allocate a new pagemap page, that the pagemap page for the new page already exists")

                   (\PUTBASE \PageMapTBL (IPLUS PAGEMAPKEY I)
                          NEXTPM)
                   (SETQ NEXTPM (IPLUS NEXTPM \PMblockSize)))
          (SETQ NEXTVMEM \FirstVmemBlock)                    (* ; 
                                      "add entry for InterfacePage which must be on FirstVMemBlock")
          (CREATEPAGES \LOCKEDPAGETABLE \NumLPTPages NIL T])
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS CHECKIF MACRO [(FLD COMPARISON VALUE STR)
                                 (COND
                                    ((NOT (COMPARISON VALUE (fetch (IFPAGE FLD) of 
                                                                                       \InterfacePage
                                                                   )))
                                     (printout T "Warning: " STR "= " (PROGN VALUE)
                                            ", but \InterfacePage says "
                                            (fetch (IFPAGE FLD) of \InterfacePage)
                                            T])
)


(ADDTOVAR INEWCOMS (FNS DUMPINITPAGES)
                       (VARS INITCONSTANTS)
                       (FNS SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES))

(ADDTOVAR RDCOMS (FNS READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE \LOCKEDPAGEP \LOOKUPPAGEMAP 
                          CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \SHOWPAGETABLE \PRINTFPTOVP))

(ADDTOVAR EXPANDMACROFNS CHECKIF .LOCKEDVPBASE. .LOCKEDVPMASK. .PAGEMAPBASE.)

(ADDTOVAR MKI.SUBFNS (\NEWPAGE . MKI.NEWPAGE)
                         (\LOCKPAGES . MKI.LOCKPAGES))

(ADDTOVAR RD.SUBFNS (\NEWPAGE . VNEWPAGE)
                        (\LOCKPAGES . VLOCKPAGES))

(ADDTOVAR RDPTRS (\REALPAGETABLE))

(ADDTOVAR RDVALS (\RPTSIZE))
EVAL@COMPILE 

(ADDTOVAR DONTCOMPILEFNS DUMPINITPAGES SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES READPAGEMAP 
                                   READPAGEMAPBLOCK CHECKIFPAGE)
)
(DEFINEQ

(\LOCKFN
  [LAMBDA (FN)                                           (* bvm%: "22-NOV-82 17:39")
    [\LOCKCELL (SETQ FN (fetch (LITATOM DEFINITIONCELL) of (EVQ FN]
    (COND
       ((fetch (DEFINITIONCELL CCODEP) of FN)
        (\LOCKCODE (fetch (DEFINITIONCELL DEFPOINTER) of FN])

(\LOCKCODE
  [LAMBDA (CODEBLOCK)                                    (* rmk%: "15-Aug-84 13:35")
    (\LOCKWORDS CODEBLOCK (UNFOLD (\#BLOCKDATACELLS CODEBLOCK)
                                     WORDSPERCELL])

(\LOCKVAR
  [LAMBDA (VAR)                                          (* lmm " 5-APR-82 00:43")
    (\LOCKCELL (fetch (LITATOM VCELL) of (EVQ VAR])

(\LOCKCELL
  [LAMBDA (X NPGS)                                       (* bvm%: "22-NOV-82 17:54")
    (\LOCKPAGES (PAGEBASE X)
           (OR NPGS 1])

(\LOCKWORDS
  [LAMBDA (BASE NWORDS)                                  (* bvm%: "22-NOV-82 17:35")
    (\LOCKPAGES (PAGEBASE BASE)
           (COND
              (NWORDS (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BASE)
                                     NWORDS)
                             WORDSPERPAGE))
              (T 1])
)
(DECLARE%: DONTCOPY 

(ADDTOVAR INEWCOMS
          (FNS \LOCKFN \LOCKVAR \LOCKCELL \LOCKWORDS \LOCKCODE)
          (ALLOCAL (ADDVARS (LOCKEDFNS \FAULTHANDLER \FAULTINIT \DOVE.FAULTINIT \D01.FAULTINIT 
                                   \DL.FAULTINIT \CHAIN.UP.RPT \MAKESPACEFORLOCKEDPAGE \PAGEFAULT 
                                   \WRITEMAP \LOOKUPPAGEMAP \LOCKEDPAGEP \LOADVMEMPAGE \MOVEREALPAGE
                                   \INVALIDADDR \INVALIDVP \SELECTREALPAGE \TRANSFERPAGE \SPECIALRP 
                                   \UPDATECHAIN \MARKPAGEVACANT \FLUSHPAGE \CLEARWORDS \FLUSHVM 
                                   \DONEWPAGE \ASSURE.FPTOVP.PAGE \DONEWEPHEMERALPAGE 
                                   \WRITEDIRTYPAGE1 \COPYSYS0 \COPYSYS0SUBR \RELEASEWORKINGSET 
                                   \DOFLUSHVM \DOLOCKPAGES \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES 
                                   \MP.ERROR RAID \DL.NEWFAULTINIT \DL.MARK.PAGES.UNAVAILABLE 
                                   \DL.UNMAPPAGES \DL.ASSIGNBUFFERS \D01.ASSIGNBUFFERS 
                                   \DOCOMPRESSVMEM \MOVEVMEMFILEPAGE \SET.VMEM.FULL.STATE \HINUM 
                                   \LONUM \ATOMCELL SETTOPVAL)
                          (LOCKEDVARS \REALPAGETABLE \RPTLAST \PAGEFAULTCOUNTER \UPDATECHAINFREQ 
                                 \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP 
                                 \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK 
                                 \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE 
                                 \VMEM.PURE.LIMIT \VMEM.FULL.STATE \GUARDVMEMFULL VMEM.COMPRESS.FLG 
                                 \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP \MACHINETYPE 
                                 \VMEMACCESSFN \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND 
                                 \MAXSWAPBUFFERS \EMUBUFFERS \#EMUBUFFERS \#SWAPBUFFERS \#DISKBUFFERS
                                 \RCLKSECOND \RCLKMILLISECOND \VALSPACE \EMUSWAPBUFFERS 
                                 \EM.CURSORBITMAP \PAGEMAP \PageMapTBL \IOCBPAGE \IOPAGE \MISCSTATS 
                                 \DEFSPACE \InterfacePage \LASTVMEMFILEPAGE \DoveIORegion 
                                 \MaxScreenPage \NEWVMEMPAGEADDED))))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA VMEM.PURE.STATE)
)
(PRETTYCOMPRINT LLFAULTCOMS)

(RPAQQ LLFAULTCOMS
       [(VARS (FAULTTEST T))
        (COMS                                                (* ; 
                                                 "Bootstrap code, run once when an image is booted")
              (FNS \FAULTINIT \D01.FAULTINIT \D01.ASSIGNBUFFERS \MAIKO.FAULTINIT \MAIKO.NEWFAULTINIT
                   \MAIKO.ASSIGNBUFFERS \M-VMEMSAVE \MAIKO.NEWPAGE)
              
              (* ;; "For setting up (and maybe eventually removing?) MAIKO-specific versions of the generic low-levle functions:")

              (FNS \MAIKO.DO.MOVDS)
              (ADDVARS (\MAIKO.MOVDS (TRUE \LOCKEDPAGEP)
                              (\MAIKO.NEWPAGE \NEWPAGE)
                              (\MAIKO.NEWPAGE \DONEWPAGE)
                              (NILL \LOCKPAGES)
                              (NILL \DOLOCKPAGES)
                              (NILL \DOTEMPLOCKPAGES)
                              (NILL \TEMPUNLOCKPAGES)
                              (NILL \UNLOCKPAGES)
                              (NILL \WRITEDIRTYPAGE)
                              (NILL \DIRTYBACKGROUND)
                              (ZERO \COUNTREALPAGES)
                              (NILL \SHOWPAGETABLE)
                              (NILL CHECKPAGEMAP)
                              (EVQ \PAGEFAULT)
                              (EVQ \LOADVMEMPAGE)
                              (NILL \LOADVMEMPAGE)
                              (TRUE \MOVEVMEMFILEPAGE)
                              (TRUE \VALIDADDRESSP)))
              (FNS \DOVE.FAULTINIT \DL.FAULTINIT \DL.NEWFAULTINIT \DL.UNMAPPAGES 
                   \DL.MARK.PAGES.UNAVAILABLE \DL.ASSIGNBUFFERS \CHAIN.UP.RPT))
        (COMS                                                (* ; "Pagefault handler")
              (FNS \FAULTHANDLER \PAGEFAULT \INVALIDADDR \INVALIDVP \FLUSHPAGE \LOADVMEMPAGE 
                   \MOVEREALPAGE \LOOKUPPAGEMAP \VALIDADDRESSP \LOCKEDPAGEP \SELECTREALPAGE 
                   \SPECIALRP \TRANSFERPAGE \UPDATECHAIN))
        (COMS                                                (* ; 
                                                           "Allocating and locking new pages")
              (FNS \NEWPAGE \DONEWPAGE \ASSURE.FPTOVP.PAGE \MAKESPACEFORLOCKEDPAGE \MOVEVMEMFILEPAGE
                   \NEWEPHEMERALPAGE \DONEWEPHEMERALPAGE \LOCKPAGES \DOLOCKPAGES \TEMPLOCKPAGES 
                   \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \UNLOCKPAGES))
        (COMS                                                (* ; "Writing out the vmem")
              (FNS \FLUSHVM \LOGOUT0 \DOFLUSHVM \RELEASEWORKINGSET \WRITEDIRTYPAGE \WRITEDIRTYPAGE1 
                   \COUNTREALPAGES))
        (COMS                                                (* ; "VMEM.PURE.STATE hack")
              (FNS \DOCOMPRESSVMEM VMEM.PURE.STATE))
        (COMS 
              (* ;; "Handling the backing store getting too full--keep running, but if we overflow, we can never \FLUSHVM because there is no place to write some pages")

              (FNS 32MBADDRESSABLE \SET.VMEM.FULL.STATE \SET.LASTVMEMFILEPAGE \DOVMEMFULLINTERRUPT 
                   \FLUSHVMOK?))
        (INITVARS (\UPDATECHAINFREQ 144Q)
               (\PAGEFAULTCOUNTER 0)
               (\DIRTYPAGECOUNTER 0)
               (\DIRTYPAGEHINT 0)
               (\LASTACCESSEDVMEMPAGE 0)
               (\MAXSHORTSEEK 1750Q)
               (\MINSHORTSEEK 24Q)
               (\MAXCLEANPROBES 24Q)
               (\VMEM.INHIBIT.WRITE)
               (\VMEM.PURE.LIMIT)
               (\VMEM.FULL.STATE)
               (\GUARDVMEMFULL 764Q)
               (VMEM.COMPRESS.FLG)
               (\DOFAULTINIT 0)
               (\VMEMACCESSFN)
               (\SYSTEMCACHEVARS)
               (\MAXSWAPBUFFERS 1)
               (\EXTENDINGVMEMFILE)
               (\MaxScreenPage 0)
               (\NEWVMEMPAGEADDED))
        (INITVARS (\LASTDIRTYCNT)
               (\LASTDIRTYFOUND)
               (\LASTDIRTYSCANPTR)
               (\DIRTYSEEKMAX 62Q))
        (COMS                                                (* ; 
                                                         "Errors signaled in the maintenance panel")
              (FNS \MP.ERROR))
        (COMS                                                (* ; 
                          "Debugging code.  Some of this also runs renamed for extra TeleRaid help")
              (FNS \ACTONVMEMFILE \SHOWPAGETABLE CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \PRINTFPTOVP 
                   \PRINTVP))
        (E (RESETSAVE (RADIX 10Q)))
        (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \ACTONVMEMFILE .VMEM.CONSISTENTP. .LOCKABLERP.)
               (COMS                                         (* ; "Virtual page flags")
                     (CONSTANTS \VMAP.DIRTY \VMAP.CLEAN \VMAP.REF \VMAP.VACANT \VMAP.FLAGS 
                            \VMAP.NOTFLAGS)
                     (RECORDS VMEMFLAGS)
                     (MACROS LOGNOT16))
               (COMS                                         (* ; "RPT constants")
                     (CONSTANTS \RPT.EMPTY \RPT.UNAVAILABLE \PAGETABLESTOPFLG \RPTENTRYLENGTH)
                     (RECORDS RPT RPT1)
                     (MACROS RPFROMRPT RPTFROMRP NPAGESMACRO))
               (COMS                                         (* ; "Virtual to file pagemap")
                     (EXPORT (CONSTANTS \MAXFILEPAGE))
                     (CONSTANTS \EMPTYPMTENTRY)
                     (RECORDS VP)
                     (MACROS .PAGEMAPBASE.))
               (COMS                                         (* ; "FP to VP stuff")
                     (RECORDS FPTOVP)
                     (CONSTANTS \NO.VMEM.PAGE)
                     (MACROS DLRPFROMFP DLFPFROMRP))
               (PROP DOPVAL \TOUCHPAGE TIMES3)
               (COMS                                         (* ; "Locked page table")
                     (MACROS .LOCKEDVPBASE. .LOCKEDVPMASK.))
               (CONSTANTS \MAXDIRTYSCANCOUNT \MINVMEMSPAREPAGES \DLBUFFERPAGES)
               (CONSTANTS 2MBPAGES)
               (GLOBALVARS \UPDATECHAINFREQ \REALPAGETABLE \RPTLAST \RPOFFSET \RPTSIZE 
                      \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP \PAGEFAULTCOUNTER \LASTDIRTYCNT 
                      \LASTDIRTYFOUND \LASTDIRTYSCANPTR \MACHINETYPE \LASTACCESSEDVMEMPAGE 
                      \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYSEEKMAX \DIRTYPAGECOUNTER 
                      \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE 
                      \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT 
                      \FPTOVP \VMEMACCESSFN \SYSTEMCACHEVARS \LASTVMEMFILEPAGE \EXTENDINGVMEMFILE 
                      \MaxScreenPage \NEWVMEMPAGEADDED)
               (GLOBALVARS \#SWAPBUFFERS \#EMUBUFFERS \#DISKBUFFERS \MAXSWAPBUFFERS \EMUSWAPBUFFERS 
                      \EMUBUFFERS \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND)
               (MACROS RWMufMan)
               (CONSTANTS (DOLOCKCHECKS NIL)))
        [COMS 

(* ;;; "MAKEINIT stuff")

              (FNS ADDPME CHECKIFPAGE DUMPINITPAGES MAKEROOMFORPME MAPPAGES READPAGEMAP 
                   READPAGEMAPBLOCK SETUPPAGEMAP)
              (DECLARE%: DONTCOPY (MACROS CHECKIF)
                     (ADDVARS (INEWCOMS (FNS DUMPINITPAGES)
                                     (VARS INITCONSTANTS)
                                     (FNS SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES))
                            (RDCOMS (FNS READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE \LOCKEDPAGEP 
                                         \LOOKUPPAGEMAP CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 
                                         \SHOWPAGETABLE \PRINTFPTOVP))
                            (EXPANDMACROFNS CHECKIF .LOCKEDVPBASE. .LOCKEDVPMASK. .PAGEMAPBASE.)
                            (MKI.SUBFNS (\NEWPAGE . MKI.NEWPAGE)
                                   (\LOCKPAGES . MKI.LOCKPAGES))
                            (RD.SUBFNS (\NEWPAGE . VNEWPAGE)
                                   (\LOCKPAGES . VLOCKPAGES))
                            (RDPTRS (\REALPAGETABLE))
                            (RDVALS (\RPTSIZE)))
                     EVAL@COMPILE
                     (ADDVARS (DONTCOMPILEFNS DUMPINITPAGES SETUPPAGEMAP ADDPME MAKEROOMFORPME 
                                     MAPPAGES READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE]
        (FNS \LOCKFN \LOCKCODE \LOCKVAR \LOCKCELL \LOCKWORDS)
        [DECLARE%: DONTCOPY
               (ADDVARS (INEWCOMS (FNS \LOCKFN \LOCKVAR \LOCKCELL \LOCKWORDS \LOCKCODE)
                               (ALLOCAL (ADDVARS (LOCKEDFNS \FAULTHANDLER \FAULTINIT \DOVE.FAULTINIT
                                                        \D01.FAULTINIT \DL.FAULTINIT \CHAIN.UP.RPT 
                                                        \MAKESPACEFORLOCKEDPAGE \PAGEFAULT \WRITEMAP
                                                        \LOOKUPPAGEMAP \LOCKEDPAGEP \LOADVMEMPAGE 
                                                        \MOVEREALPAGE \INVALIDADDR \INVALIDVP 
                                                        \SELECTREALPAGE \TRANSFERPAGE \SPECIALRP 
                                                        \UPDATECHAIN \MARKPAGEVACANT \FLUSHPAGE 
                                                        \CLEARWORDS \FLUSHVM \DONEWPAGE 
                                                        \ASSURE.FPTOVP.PAGE \DONEWEPHEMERALPAGE 
                                                        \WRITEDIRTYPAGE1 \COPYSYS0 \COPYSYS0SUBR 
                                                        \RELEASEWORKINGSET \DOFLUSHVM \DOLOCKPAGES 
                                                        \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \MP.ERROR 
                                                        RAID \DL.NEWFAULTINIT 
                                                        \DL.MARK.PAGES.UNAVAILABLE \DL.UNMAPPAGES 
                                                        \DL.ASSIGNBUFFERS \D01.ASSIGNBUFFERS 
                                                        \DOCOMPRESSVMEM \MOVEVMEMFILEPAGE 
                                                        \SET.VMEM.FULL.STATE \HINUM \LONUM \ATOMCELL
                                                        SETTOPVAL)
                                               (LOCKEDVARS \REALPAGETABLE \RPTLAST \PAGEFAULTCOUNTER
                                                      \UPDATECHAINFREQ \RPOFFSET \RPTSIZE 
                                                      \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP 
                                                      \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK 
                                                      \MAXCLEANPROBES \MINSHORTSEEK \DIRTYPAGECOUNTER
                                                      \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE 
                                                      \VMEM.PURE.LIMIT \VMEM.FULL.STATE 
                                                      \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE
                                                      \MISCSTACKBASE \DOFAULTINIT \FPTOVP 
                                                      \MACHINETYPE \VMEMACCESSFN \TELERAIDBUFFER 
                                                      \EMUDISKBUFFERS \EMUDISKBUFEND \MAXSWAPBUFFERS
                                                      \EMUBUFFERS \#EMUBUFFERS \#SWAPBUFFERS 
                                                      \#DISKBUFFERS \RCLKSECOND \RCLKMILLISECOND 
                                                      \VALSPACE \EMUSWAPBUFFERS \EM.CURSORBITMAP 
                                                      \PAGEMAP \PageMapTBL \IOCBPAGE \IOPAGE 
                                                      \MISCSTATS \DEFSPACE \InterfacePage 
                                                      \LASTVMEMFILEPAGE \DoveIORegion \MaxScreenPage
                                                      \NEWVMEMPAGEADDED]
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA CHECKPAGEMAP \SHOWPAGETABLE VMEM.PURE.STATE \COUNTREALPAGES 
                            \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \DOTEMPLOCKPAGES 
                            \DOLOCKPAGES \LOCKPAGES \LOADVMEMPAGE])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA CHECKPAGEMAP \SHOWPAGETABLE VMEM.PURE.STATE \COUNTREALPAGES \WRITEDIRTYPAGE 
                         \UNLOCKPAGES \TEMPUNLOCKPAGES \DOTEMPLOCKPAGES \DOLOCKPAGES \LOCKPAGES 
                         \LOADVMEMPAGE)
)
(PUTPROPS LLFAULT COPYRIGHT ("Venue & Xerox Corporation" 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 
3705Q 3706Q 3707Q 3710Q 3711Q))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (31155Q 64663Q (\FAULTINIT 31167Q . 40416Q) (\D01.FAULTINIT 40420Q . 46045Q) (
\D01.ASSIGNBUFFERS 46047Q . 51614Q) (\MAIKO.FAULTINIT 51616Q . 54403Q) (\MAIKO.NEWFAULTINIT 54405Q . 
55632Q) (\MAIKO.ASSIGNBUFFERS 55634Q . 61307Q) (\M-VMEMSAVE 61311Q . 64426Q) (\MAIKO.NEWPAGE 64430Q . 
64661Q)) (65063Q 72470Q (\MAIKO.DO.MOVDS 65075Q . 72466Q)) (73627Q 164307Q (\DOVE.FAULTINIT 73641Q . 
100234Q) (\DL.FAULTINIT 100236Q . 105327Q) (\DL.NEWFAULTINIT 105331Q . 152043Q) (\DL.UNMAPPAGES 
152045Q . 153033Q) (\DL.MARK.PAGES.UNAVAILABLE 153035Q . 153773Q) (\DL.ASSIGNBUFFERS 153775Q . 157516Q
) (\CHAIN.UP.RPT 157520Q . 164305Q)) (164352Q 250664Q (\FAULTHANDLER 164364Q . 165242Q) (\PAGEFAULT 
165244Q . 171003Q) (\INVALIDADDR 171005Q . 171261Q) (\INVALIDVP 171263Q . 171522Q) (\FLUSHPAGE 171524Q
 . 176665Q) (\LOADVMEMPAGE 176667Q . 203040Q) (\MOVEREALPAGE 203042Q . 206302Q) (\LOOKUPPAGEMAP 
206304Q . 207276Q) (\VALIDADDRESSP 207300Q . 207570Q) (\LOCKEDPAGEP 207572Q . 210774Q) (
\SELECTREALPAGE 210776Q . 232733Q) (\SPECIALRP 232735Q . 233752Q) (\TRANSFERPAGE 233754Q . 241615Q) (
\UPDATECHAIN 241617Q . 250662Q)) (250746Q 325516Q (\NEWPAGE 250760Q . 252755Q) (\DONEWPAGE 252757Q . 
262516Q) (\ASSURE.FPTOVP.PAGE 262520Q . 265472Q) (\MAKESPACEFORLOCKEDPAGE 265474Q . 273076Q) (
\MOVEVMEMFILEPAGE 273100Q . 275521Q) (\NEWEPHEMERALPAGE 275523Q . 276254Q) (\DONEWEPHEMERALPAGE 
276256Q . 303474Q) (\LOCKPAGES 303476Q . 304122Q) (\DOLOCKPAGES 304124Q . 313670Q) (\TEMPLOCKPAGES 
313672Q . 314401Q) (\DOTEMPLOCKPAGES 314403Q . 317416Q) (\TEMPUNLOCKPAGES 317420Q . 322302Q) (
\UNLOCKPAGES 322304Q . 325514Q)) (325564Q 364701Q (\FLUSHVM 325576Q . 332240Q) (\LOGOUT0 332242Q . 
334112Q) (\DOFLUSHVM 334114Q . 344600Q) (\RELEASEWORKINGSET 344602Q . 346372Q) (\WRITEDIRTYPAGE 
346374Q . 362140Q) (\WRITEDIRTYPAGE1 362142Q . 363467Q) (\COUNTREALPAGES 363471Q . 364677Q)) (364747Q 
370276Q (\DOCOMPRESSVMEM 364761Q . 367277Q) (VMEM.PURE.STATE 367301Q . 370274Q)) (370545Q 402263Q (
32MBADDRESSABLE 370557Q . 371225Q) (\SET.VMEM.FULL.STATE 371227Q . 373150Q) (\SET.LASTVMEMFILEPAGE 
373152Q . 374523Q) (\DOVMEMFULLINTERRUPT 374525Q . 400270Q) (\FLUSHVMOK? 400272Q . 402261Q)) (403737Q 
404373Q (\MP.ERROR 403751Q . 404371Q)) (404524Q 434334Q (\ACTONVMEMFILE 404536Q . 405335Q) (
\SHOWPAGETABLE 405337Q . 413040Q) (CHECKPAGEMAP 413042Q . 420724Q) (CHECKFPTOVP 420726Q . 421740Q) (
CHECKFPTOVP1 421742Q . 423131Q) (\PRINTFPTOVP 423133Q . 434016Q) (\PRINTVP 434020Q . 434332Q)) (
454624Q 504322Q (ADDPME 454636Q . 460205Q) (CHECKIFPAGE 460207Q . 460461Q) (DUMPINITPAGES 460463Q . 
466101Q) (MAKEROOMFORPME 466103Q . 467603Q) (MAPPAGES 467605Q . 471004Q) (READPAGEMAP 471006Q . 
500163Q) (READPAGEMAPBLOCK 500165Q . 500755Q) (SETUPPAGEMAP 500757Q . 504320Q)) (507431Q 511777Q (
\LOCKFN 507443Q . 510146Q) (\LOCKCODE 510150Q . 510512Q) (\LOCKVAR 510514Q . 510764Q) (\LOCKCELL 
510766Q . 511232Q) (\LOCKWORDS 511234Q . 511775Q)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "10-Feb-2021 22:44:43" {DSK}<home>larry>ilisp>medley>sources>LLFAULT.;5 507542Q

      changes to%:  (FNS \FLUSHVM \DOFLUSHVM \FAULTINIT \D01.FAULTINIT \D01.ASSIGNBUFFERS 
                         \MAIKO.FAULTINIT \MAIKO.NEWFAULTINIT \MAIKO.ASSIGNBUFFERS \M-VMEMSAVE 
                         \MAIKO.NEWPAGE \MAIKO.DO.MOVDS \DOVE.FAULTINIT \DL.FAULTINIT 
                         \DL.NEWFAULTINIT \DL.UNMAPPAGES \DL.MARK.PAGES.UNAVAILABLE \DL.ASSIGNBUFFERS
                         \CHAIN.UP.RPT \FAULTHANDLER \PAGEFAULT \INVALIDADDR \INVALIDVP \FLUSHPAGE 
                         \LOADVMEMPAGE \MOVEREALPAGE \LOOKUPPAGEMAP \VALIDADDRESSP \LOCKEDPAGEP 
                         \SELECTREALPAGE \SPECIALRP \TRANSFERPAGE \UPDATECHAIN \NEWPAGE \DONEWPAGE 
                         \ASSURE.FPTOVP.PAGE \MAKESPACEFORLOCKEDPAGE \MOVEVMEMFILEPAGE 
                         \NEWEPHEMERALPAGE \DONEWEPHEMERALPAGE \LOCKPAGES \DOLOCKPAGES \TEMPLOCKPAGES
                         \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \UNLOCKPAGES \LOGOUT0 \FLUSHVMOK?)
                    (VARS LLFAULTCOMS)

      previous date%: "10-Feb-2021 22:40:24" {DSK}<home>larry>ilisp>medley>sources>LLFAULT.;4)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 2021 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT LLFAULTCOMS)

(RPAQQ LLFAULTCOMS
       [(VARS (FAULTTEST T))
        (COMS                                                (* ; 
                                                 "Bootstrap code, run once when an image is booted")
              (FNS \FAULTINIT \D01.FAULTINIT \D01.ASSIGNBUFFERS \MAIKO.FAULTINIT \MAIKO.NEWFAULTINIT
                   \MAIKO.ASSIGNBUFFERS \M-VMEMSAVE \MAIKO.NEWPAGE)
              
              (* ;; "For setting up (and maybe eventually removing?) MAIKO-specific versions of the generic low-levle functions:")

              (FNS \MAIKO.DO.MOVDS)
              (ADDVARS (\MAIKO.MOVDS (TRUE \LOCKEDPAGEP)
                              (\MAIKO.NEWPAGE \NEWPAGE)
                              (\MAIKO.NEWPAGE \DONEWPAGE)
                              (NILL \LOCKPAGES)
                              (NILL \DOLOCKPAGES)
                              (NILL \DOTEMPLOCKPAGES)
                              (NILL \TEMPUNLOCKPAGES)
                              (NILL \UNLOCKPAGES)
                              (NILL \WRITEDIRTYPAGE)
                              (NILL \DIRTYBACKGROUND)
                              (ZERO \COUNTREALPAGES)
                              (NILL \SHOWPAGETABLE)
                              (NILL CHECKPAGEMAP)
                              (EVQ \PAGEFAULT)
                              (EVQ \LOADVMEMPAGE)
                              (NILL \LOADVMEMPAGE)
                              (TRUE \MOVEVMEMFILEPAGE)
                              (TRUE \VALIDADDRESSP)))
              (FNS \DOVE.FAULTINIT \DL.FAULTINIT \DL.NEWFAULTINIT \DL.UNMAPPAGES 
                   \DL.MARK.PAGES.UNAVAILABLE \DL.ASSIGNBUFFERS \CHAIN.UP.RPT))
        (COMS                                                (* ; "Pagefault handler")
              (FNS \FAULTHANDLER \PAGEFAULT \INVALIDADDR \INVALIDVP \FLUSHPAGE \LOADVMEMPAGE 
                   \MOVEREALPAGE \LOOKUPPAGEMAP \VALIDADDRESSP \LOCKEDPAGEP \SELECTREALPAGE 
                   \SPECIALRP \TRANSFERPAGE \UPDATECHAIN))
        (COMS                                                (* ; 
                                                           "Allocating and locking new pages")
              (FNS \NEWPAGE \DONEWPAGE \ASSURE.FPTOVP.PAGE \MAKESPACEFORLOCKEDPAGE \MOVEVMEMFILEPAGE
                   \NEWEPHEMERALPAGE \DONEWEPHEMERALPAGE \LOCKPAGES \DOLOCKPAGES \TEMPLOCKPAGES 
                   \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \UNLOCKPAGES))
        (COMS                                                (* ; "Writing out the vmem")
              (FNS \FLUSHVM \LOGOUT0 \DOFLUSHVM \RELEASEWORKINGSET \WRITEDIRTYPAGE \WRITEDIRTYPAGE1 
                   \COUNTREALPAGES))
        (COMS                                                (* ; "VMEM.PURE.STATE hack")
              (FNS \DOCOMPRESSVMEM VMEM.PURE.STATE))
        (COMS 
              (* ;; "Handling the backing store getting too full--keep running, but if we overflow, we can never \FLUSHVM because there is no place to write some pages")

              (FNS 32MBADDRESSABLE \SET.VMEM.FULL.STATE \SET.LASTVMEMFILEPAGE \DOVMEMFULLINTERRUPT 
                   \FLUSHVMOK?))
        (INITVARS (\UPDATECHAINFREQ 100)
               (\PAGEFAULTCOUNTER 0)
               (\DIRTYPAGECOUNTER 0)
               (\DIRTYPAGEHINT 0)
               (\LASTACCESSEDVMEMPAGE 0)
               (\MAXSHORTSEEK 1000)
               (\MINSHORTSEEK 20)
               (\MAXCLEANPROBES 20)
               (\VMEM.INHIBIT.WRITE)
               (\VMEM.PURE.LIMIT)
               (\VMEM.FULL.STATE)
               (\GUARDVMEMFULL 500)
               (VMEM.COMPRESS.FLG)
               (\DOFAULTINIT 0)
               (\VMEMACCESSFN)
               (\SYSTEMCACHEVARS)
               (\MAXSWAPBUFFERS 1)
               (\EXTENDINGVMEMFILE)
               (\MaxScreenPage 0)
               (\NEWVMEMPAGEADDED))
        (INITVARS (\LASTDIRTYCNT)
               (\LASTDIRTYFOUND)
               (\LASTDIRTYSCANPTR)
               (\DIRTYSEEKMAX 50))
        (COMS                                                (* ; 
                                                         "Errors signaled in the maintenance panel")
              (FNS \MP.ERROR))
        (COMS                                                (* ; 
                          "Debugging code.  Some of this also runs renamed for extra TeleRaid help")
              (FNS \ACTONVMEMFILE \SHOWPAGETABLE CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \PRINTFPTOVP 
                   \PRINTVP))
        (E (RESETSAVE (RADIX 8)))
        (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \ACTONVMEMFILE .VMEM.CONSISTENTP. .LOCKABLERP.)
               (COMS                                         (* ; "Virtual page flags")
                     (CONSTANTS \VMAP.DIRTY \VMAP.CLEAN \VMAP.REF \VMAP.VACANT \VMAP.FLAGS 
                            \VMAP.NOTFLAGS)
                     (RECORDS VMEMFLAGS)
                     (MACROS LOGNOT16))
               (COMS                                         (* ; "RPT constants")
                     (CONSTANTS \RPT.EMPTY \RPT.UNAVAILABLE \PAGETABLESTOPFLG \RPTENTRYLENGTH)
                     (RECORDS RPT RPT1)
                     (MACROS RPFROMRPT RPTFROMRP NPAGESMACRO))
               (COMS                                         (* ; "Virtual to file pagemap")
                     (EXPORT (CONSTANTS \MAXFILEPAGE))
                     (CONSTANTS \EMPTYPMTENTRY)
                     (RECORDS VP)
                     (MACROS .PAGEMAPBASE.))
               (COMS                                         (* ; "FP to VP stuff")
                     (RECORDS FPTOVP)
                     (CONSTANTS \NO.VMEM.PAGE)
                     (MACROS DLRPFROMFP DLFPFROMRP))
               (PROP DOPVAL \TOUCHPAGE TIMES3)
               (COMS                                         (* ; "Locked page table")
                     (MACROS .LOCKEDVPBASE. .LOCKEDVPMASK.))
               (CONSTANTS \MAXDIRTYSCANCOUNT \MINVMEMSPAREPAGES \DLBUFFERPAGES)
               (CONSTANTS 2MBPAGES)
               (GLOBALVARS \UPDATECHAINFREQ \REALPAGETABLE \RPTLAST \RPOFFSET \RPTSIZE 
                      \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP \PAGEFAULTCOUNTER \LASTDIRTYCNT 
                      \LASTDIRTYFOUND \LASTDIRTYSCANPTR \MACHINETYPE \LASTACCESSEDVMEMPAGE 
                      \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYSEEKMAX \DIRTYPAGECOUNTER 
                      \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE 
                      \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT 
                      \FPTOVP \VMEMACCESSFN \SYSTEMCACHEVARS \LASTVMEMFILEPAGE \EXTENDINGVMEMFILE 
                      \MaxScreenPage \NEWVMEMPAGEADDED)
               (GLOBALVARS \#SWAPBUFFERS \#EMUBUFFERS \#DISKBUFFERS \MAXSWAPBUFFERS \EMUSWAPBUFFERS 
                      \EMUBUFFERS \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND)
               (MACROS RWMufMan)
               (CONSTANTS (DOLOCKCHECKS NIL)))
        [COMS 

(* ;;; "MAKEINIT stuff")

              (FNS ADDPME CHECKIFPAGE DUMPINITPAGES MAKEROOMFORPME MAPPAGES READPAGEMAP 
                   READPAGEMAPBLOCK SETUPPAGEMAP)
              (DECLARE%: DONTCOPY (MACROS CHECKIF)
                     (ADDVARS (INEWCOMS (FNS DUMPINITPAGES)
                                     (VARS INITCONSTANTS)
                                     (FNS SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES))
                            (RDCOMS (FNS READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE \LOCKEDPAGEP 
                                         \LOOKUPPAGEMAP CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 
                                         \SHOWPAGETABLE \PRINTFPTOVP))
                            (EXPANDMACROFNS CHECKIF .LOCKEDVPBASE. .LOCKEDVPMASK. .PAGEMAPBASE.)
                            (MKI.SUBFNS (\NEWPAGE . MKI.NEWPAGE)
                                   (\LOCKPAGES . MKI.LOCKPAGES))
                            (RD.SUBFNS (\NEWPAGE . VNEWPAGE)
                                   (\LOCKPAGES . VLOCKPAGES))
                            (RDPTRS (\REALPAGETABLE))
                            (RDVALS (\RPTSIZE)))
                     EVAL@COMPILE
                     (ADDVARS (DONTCOMPILEFNS DUMPINITPAGES SETUPPAGEMAP ADDPME MAKEROOMFORPME 
                                     MAPPAGES READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE]
        (FNS \LOCKFN \LOCKCODE \LOCKVAR \LOCKCELL \LOCKWORDS)
        [DECLARE%: DONTCOPY
               (ADDVARS (INEWCOMS (FNS \LOCKFN \LOCKVAR \LOCKCELL \LOCKWORDS \LOCKCODE)
                               (ALLOCAL (ADDVARS (LOCKEDFNS \FAULTHANDLER \FAULTINIT \DOVE.FAULTINIT
                                                        \D01.FAULTINIT \DL.FAULTINIT \CHAIN.UP.RPT 
                                                        \MAKESPACEFORLOCKEDPAGE \PAGEFAULT \WRITEMAP
                                                        \LOOKUPPAGEMAP \LOCKEDPAGEP \LOADVMEMPAGE 
                                                        \MOVEREALPAGE \INVALIDADDR \INVALIDVP 
                                                        \SELECTREALPAGE \TRANSFERPAGE \SPECIALRP 
                                                        \UPDATECHAIN \MARKPAGEVACANT \FLUSHPAGE 
                                                        \CLEARWORDS \FLUSHVM \DONEWPAGE 
                                                        \ASSURE.FPTOVP.PAGE \DONEWEPHEMERALPAGE 
                                                        \WRITEDIRTYPAGE1 \COPYSYS0 \COPYSYS0SUBR 
                                                        \RELEASEWORKINGSET \DOFLUSHVM \DOLOCKPAGES 
                                                        \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \MP.ERROR 
                                                        RAID \DL.NEWFAULTINIT 
                                                        \DL.MARK.PAGES.UNAVAILABLE \DL.UNMAPPAGES 
                                                        \DL.ASSIGNBUFFERS \D01.ASSIGNBUFFERS 
                                                        \DOCOMPRESSVMEM \MOVEVMEMFILEPAGE 
                                                        \SET.VMEM.FULL.STATE \HINUM \LONUM \ATOMCELL
                                                        SETTOPVAL)
                                               (LOCKEDVARS \REALPAGETABLE \RPTLAST \PAGEFAULTCOUNTER
                                                      \UPDATECHAINFREQ \RPOFFSET \RPTSIZE 
                                                      \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP 
                                                      \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK 
                                                      \MAXCLEANPROBES \MINSHORTSEEK \DIRTYPAGECOUNTER
                                                      \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE 
                                                      \VMEM.PURE.LIMIT \VMEM.FULL.STATE 
                                                      \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE
                                                      \MISCSTACKBASE \DOFAULTINIT \FPTOVP 
                                                      \MACHINETYPE \VMEMACCESSFN \TELERAIDBUFFER 
                                                      \EMUDISKBUFFERS \EMUDISKBUFEND \MAXSWAPBUFFERS
                                                      \EMUBUFFERS \#EMUBUFFERS \#SWAPBUFFERS 
                                                      \#DISKBUFFERS \RCLKSECOND \RCLKMILLISECOND 
                                                      \VALSPACE \EMUSWAPBUFFERS \EM.CURSORBITMAP 
                                                      \PAGEMAP \PageMapTBL \IOCBPAGE \IOPAGE 
                                                      \MISCSTATS \DEFSPACE \InterfacePage 
                                                      \LASTVMEMFILEPAGE \DoveIORegion \MaxScreenPage
                                                      \NEWVMEMPAGEADDED]
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA VMEM.PURE.STATE])

(RPAQQ FAULTTEST T)



(* ; "Bootstrap code, run once when an image is booted")

(DEFINEQ

(\FAULTINIT
  [LAMBDA NIL                                                (* ; "Edited 30-Mar-88 17:30 by Snow")

(* ;;; "retrieves some constants from Interface page for the swapper and performs other initialization that must happen immediately.  Called when starting up, and also when \FAULTHANDLER context starts, in case init hasn't happened yet, as e.g.  from MAKEINIT")

    (SETQ \MACHINETYPE (fetch MachineType of \InterfacePage))
    [PROG NIL
          (COND
             ((EQ \MACHINETYPE \MAIKO)
              (\MAIKO.FAULTINIT)
              (RETURN NIL)))
          (OR (NEQ (fetch FPTOVPStart of \InterfacePage)
                   0)
              (\MP.ERROR \MP.OBSOLETEVMEM "No FPTOVP"))
          (COND
             ((AND (NEQ 0 (fetch (IFPAGE FullSpaceUsed) of \InterfacePage))
                   (SELECTC \MACHINETYPE
                       (\DORADO NIL)
                       (\DANDELION (EQ 0 (fetch (IFPAGE DL24BitAddressable) of \InterfacePage
                                                )))
                       (\DAYBREAK NIL)
                       T))
              (\MP.ERROR \MP.32MBINUSE "Sysout contains virtual pages not addressable by machine"
                     )))
          (SETQ \LASTDIRTYSCANPTR)
          (SELECTC \MACHINETYPE
              (\DANDELION (\DL.FAULTINIT))
              (\DAYBREAK (\DOVE.FAULTINIT))
              (\D01.FAULTINIT))                          (* ; 
                                            "Have to set \EM.CURSORBITMAP before faults can happen")

     (* ;; "But you can't call \SETIOPOINTERS on a Daybreak until after the Dove IO Region is mapped, which happens in \DL.NEWFAULTINIT")

          (\SETIOPOINTERS)
          (COND
             ((IGREATERP (fetch (IFPAGE NActivePages) of \InterfacePage)
                     (IDIFFERENCE \LASTVMEMFILEPAGE \GUARDVMEMFULL))
                                                             (* ; "Vmem getting full!")
              (\SET.VMEM.FULL.STATE]
    (COND
       ((EQ (PROG1 \DOFAULTINIT (SETQ \DOFAULTINIT NIL))
            T)                                               (* ; 
                                              "true after \FLUSHVM.  Need to rebuild some contexts")
        (replace (IFPAGE KbdFXP) of \InterfacePage with (\MAKEFRAME
                                                                     (COND
                                                                        ((fetch (LITATOM CCODEP)
                                                                            of '\KEYHANDLER)
                                                                         (FUNCTION \KEYHANDLER))
                                                                        (T '\DUMMYKEYHANDLER))
                                                                     \KBDSTACKBASE
                                                                     (IPLUS \KBDSTACKBASE 
                                                                            \StackAreaSize)
                                                                     0 0))
        (replace (IFPAGE MiscFXP) of \InterfacePage with (\MAKEFRAME
                                                                      (FUNCTION \DOMISCAPPLY)
                                                                      \MISCSTACKBASE
                                                                      (IPLUS \MISCSTACKBASE 
                                                                             \StackAreaSize)
                                                                      0 0))
        T])

(\D01.FAULTINIT
  [LAMBDA NIL                                                (* bvm%: "20-Oct-86 18:19")
    (SETQ \VMEMACCESSFN (FUNCTION \M44ACTONVMEMFILE))
    (SETQ \REALPAGETABLE (fetch (IFPAGE REALPAGETABLEPTR) of \InterfacePage))

    (* ;; "Note: these SETQ's do not reference count, since the values are all smallp's and emulator addresses (in atom space)")

    (SETQ \RPOFFSET (SIGNED (fetch (IFPAGE RPOFFSET) of \InterfacePage)
                           BITSPERWORD))
    (SETQ \RPTSIZE (fetch (IFPAGE RPTSIZE) of \InterfacePage))
                                                             (* ; 
                                                "Initialize the software clocks from alto emulator")
    (\BLT (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
          (EMADDRESS \RTCSECONDS)
          (UNFOLD 3 WORDSPERCELL))
    [SETQ \RCLKMILLISECOND (CONSTANT (OR (SMALLP \ALTO.RCLKMILLISECOND)
                                         (ERROR \ALTO.RCLKMILLISECOND 
                                                "\ALTO.RCLKMILLISECOND isn't a SMALLP???"]

(* ;;; "\ALTO.RCLKMILLISECOND must be a SMALLP here so as not to cause any refcnt or pagefault activity.  \RCLKSECOND is large and has to live on \MISCSTATS, since there is no convenient way to lock a random cell.")

    (SETQ.NOREF \RCLKSECOND (LOCF (fetch RCLKSECOND of \MISCSTATS)))

(* ;;; "Note the SETQ.NOREF for \RCLKSECOND in order to guarantee no refcnt'ing (which might pagefault) Note that these LOADBYTE expressions are compiled as constants")

    (replace (FIXP HINUM) of \RCLKSECOND with (LOADBYTE \ALTO.RCLKSECOND 16 16))
    (replace (FIXP LONUM) of \RCLKSECOND with (LOADBYTE \ALTO.RCLKSECOND 0 16))
    [COND
       ((AND (EQ \MACHINETYPE \DORADO)
             (ILEQ 5124 (fetch RVersion of \InterfacePage)))
        (replace NSHost0 of \InterfacePage with 0)
        (replace NSHost1 of \InterfacePage with 21898)
        (replace NSHost2 of \InterfacePage
           with (IPLUS (MASK.1'S 15 1)
                           (for I (N _ 0) from 1168 to 1175
                              do                         (* ; 
                           "Mufflers `2220Q' thru `2227Q' hold the bits of the basic serial number")
                                    [SETQ N (IPLUS (LLSH N 1)
                                                   (COND
                                                      ((BITTEST (RWMufMan I)
                                                              (MASK.1'S 15 1))
                                                       0)
                                                      (T 1] finally (RETURN N]
    (\CHAIN.UP.RPT)
    (\D01.ASSIGNBUFFERS])

(\D01.ASSIGNBUFFERS
  [LAMBDA NIL                                                (* bvm%: "20-Oct-86 18:21")
    (PROGN                                                   (* ; "Assign swap buffer")
           (SETQ \EMBUFVP (fetch (IFPAGE EMBUFVP) of \InterfacePage))
           (SETQ \EMBUFBASE (EMPOINTER (UNFOLD \EMBUFVP WORDSPERPAGE)))
           (SETQ \EMBUFRP (\READRP \EMBUFVP)))
    (PROG ((EMBUF (fetch (IFPAGE EMUBUFFERS) of \InterfacePage))
           (EMLEN (fetch (IFPAGE EMUBUFLENGTH) of \InterfacePage))
           EXTRALEN NPAGES)
          [add EMLEN (IDIFFERENCE EMBUF (SETQ EMBUF (CEIL EMBUF WORDSPERPAGE]
                                                             (* ; 
                                             "Round up to a page boundary and throw out the excess")
          (SETQ EXTRALEN (IMOD EMLEN WORDSPERPAGE))
          (add EXTRALEN (COND
                               ((ILESSP EXTRALEN 100)
                                (TIMES 2 WORDSPERPAGE))
                               (T WORDSPERPAGE)))
          (SETQ NPAGES (FOLDLO (SETQ EMLEN (IDIFFERENCE EMLEN EXTRALEN))
                              WORDSPERPAGE))
          (OR (IGEQ NPAGES 4)
              (RAID "No swap buffer space"))
          (SETQ \TELERAIDBUFFER (EMPOINTER EMBUF))
          (SETQ \EMUBUFFERS (\ADDBASE \TELERAIDBUFFER WORDSPERPAGE))
          (SETQ \#EMUBUFFERS (SETQ NPAGES (SUB1 NPAGES)))
          (SETQ \#SWAPBUFFERS (IMIN \MAXSWAPBUFFERS (IQUOTIENT NPAGES 2)))
          (SETQ \#DISKBUFFERS (IDIFFERENCE \#EMUBUFFERS \#SWAPBUFFERS))
          (SETQ \EMUDISKBUFFERS \EMUBUFFERS)
          (SETQ \EMUDISKBUFEND (\ADDBASE \EMUDISKBUFFERS (UNFOLD \#DISKBUFFERS WORDSPERPAGE)))
          (SETQ \EMUSWAPBUFFERS \EMUDISKBUFEND)
          (\INITBFS (\ADDBASE \EMUBUFFERS (UNFOLD NPAGES WORDSPERPAGE))
                 EXTRALEN T])

(\MAIKO.FAULTINIT
  [LAMBDA NIL                                                (* ; "Edited  2-Jan-93 12:25 by jds")
    (SETQ \VMEMACCESSFN (FUNCTION NILL))                     (* ; "This variable must be the name of function that may be ACTONVMEMFILE that may write back  from VP to FP. But , in Katana type, this function may be required (by tt)")
    (SETQ \IOCBPAGE (create POINTER
                           PAGE# _ \VP.IOCBS))

    (* ;; "MOVD all the Maiko-specific low-level functions onto their generic counterparts:")

    (\MAIKO.DO.MOVDS)
    (\MAIKO.NEWFAULTINIT)
    (SETQ \RCLKMILLISECOND 1000)
    (SETQ \RCLKSECOND 1000000)
    (\RCLK (LOCF (fetch BASECLOCK of \MISCSTATS)))   (* ; "Reset base clock ")
    (\PUTBASEPTR (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
           0 NIL)                                            (* ; "Clear the seconds timer (by tt)")
    (\PUTBASEPTR (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS))
           0 NIL)                                            (* ; "Clear the milliseconds timer")
                                                             (* SETQ \LASTVMEMFILEPAGE
                                                           (fetch (IFPAGE DLLastVmemPage) of 
                                                           \InterfacePage))
    (\SETIOPOINTERS])

(\MAIKO.NEWFAULTINIT
  [LAMBDA NIL                                                (* ; 
                                                         "Edited 26-Feb-88 14:07 by Osamu Nakamura")

    (* ;; "We have just started up on a Katana.  Boot code (SYSOUT Loader) may map FP to VP(VP is same map to RP). Therefore, in this function, only done the initialization of the gloval variables (particularly, the variables about Buffers). And, there is not /REALPAGETABLE in Katana.")

    (PROG ((NBUFFERS (IDIFFERENCE \DLBUFFERPAGES 2)))        (* ; "Allocate buffers")
          (\MAIKO.ASSIGNBUFFERS (create POINTER
                                           PAGE# _ \VP.BUFFERS)
                 NBUFFERS])

(\MAIKO.ASSIGNBUFFERS
  [LAMBDA (BASE NPAGES)                                      (* ; 
                                                           "Edited 14-May-88 18:31 by JMTurn")
    (PROGN                                                   (* ; 
                    "Allocate a page to hold name and password, and perhaps other ephemeral things")
           (replace (IFPAGE UserNameAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 1
                                                                                            )))
           (replace (IFPAGE UserPswdAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 
                                                                                            33)))
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -1))
    (PROGN                                                   (* ; "Assign swap buffer")
           (SETQ \EMBUFBASE BASE)
           (SETQ \EMBUFVP (fetch (POINTER PAGE#) of BASE))
           (SETQ \EMBUFRP \EMBUFVP)
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -1))
    (PROGN                                                   (* ; "Assign ether buffers")
           (replace (IFPAGE MDSZoneLength) of \InterfacePage with (UNFOLD 2 WORDSPERPAGE)
                  )
           (replace (IFPAGE MDSZone) of \InterfacePage with (\LOLOC BASE))
           (SETQ BASE (\ADDBASE BASE (UNFOLD 2 WORDSPERPAGE)))
           (SETQ \TELERAIDBUFFER BASE)
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -3))
    (PROGN                                                   (* ; "Divvy up buffer space")
           (SETQ \#SWAPBUFFERS (SETQ \#EMUBUFFERS NPAGES))
           (SETQ \#DISKBUFFERS 0)
           (SETQ \EMUSWAPBUFFERS (SETQ \EMUBUFFERS BASE])

(\M-VMEMSAVE
  [LAMBDA NIL                                                (* ; 
                                                           "Edited 20-Apr-88 10:28 by MASINTER")
    (PROG ((SCRATCHBUF \EMUSWAPBUFFERS))
          (replace (IFPAGE MISCSTACKRESULT) of \InterfacePage with T)
          [COND
             (\VMEM.PURE.LIMIT                               (* ; 
                                            "Maintaining file consistency: move high water mark up")
                    (COND
                       (VMEM.COMPRESS.FLG (\DOCOMPRESSVMEM)))
                    (SETQ \VMEM.PURE.LIMIT (fetch (IFPAGE NActivePages) of \InterfacePage]
          (COND
             ((.VMEM.CONSISTENTP.)
              (replace (IFPAGE Key) of \InterfacePage with (LOGNOT16 \IFPValidKey))
                                                             (* ; 
                                                 "Invalidate vmem and write out the Interface page")

              (* ;; "following form doesn't eval for KATANA (\TRANSFERPAGE IFPVP \FirstVmemBlock (RPTFROMRP (\READRP IFPVP)) T NIL)")

              ))
          (replace (IFPAGE Key) of \InterfacePage with \IFPValidKey)
          (\BLT SCRATCHBUF \InterfacePage WORDSPERPAGE)      (* ; 
                              "Make its current fx point at user context, i.e.  the \FLUSHVM frame")
          (replace (IFPAGE CurrentFXP) of SCRATCHBUF with (fetch (IFPAGE MiscFXP)
                                                                         of \InterfacePage))
          (SUBRCALL VMEMSAVE)
          (RETURN NIL])

(\MAIKO.NEWPAGE
  [LAMBDA (BASE NOERROR LOCK?)                               (* ; 
                                                           "Edited 20-Apr-88 10:28 by MASINTER")
    (SUBRCALL NEWPAGE BASE])
)



(* ;; 
"For setting up (and maybe eventually removing?) MAIKO-specific versions of the generic low-levle functions:"
)

(DEFINEQ

(\MAIKO.DO.MOVDS
  [LAMBDA NIL                                                (* ; 
                                                      "Edited  2-Nov-92 03:57 by sybalsky:mv:envos")

    (* ;; "MOVD all the Maiko-specific low-level functions onto their generic counterparts.  This function is called from \MAIKO.FAULTINIT when the system is started up, and called explicitly during the LOADUP process to get everything in a state to run the ethernet.")

    (* ;; "THIS IS WHERE CHANGES SHOULD HAPPEN TO MAKE SUN LOADUPS RUN ON D-MACHINES (BY ADDING A \MAIKO.UNDO.MOVDS CALL AT VMEM SAVING TIME, AND ADDING A SYBMOL TO SAVE THE GENERIC DEFINITION ON TO THE MOVDS LIST.")

    (FOR PAIR IN \MAIKO.MOVDS DO 

                                 (* ;; "This is like MOVD, but absolutely no consing is done, frame names are not changed, etc.  So that no CONSING happens before all the MOVDs are finished -- prevents new-page allocation.")

                                            (LET [(FROMCELL (fetch (LITATOM DEFINITIONCELL)
                                                               of (CAR PAIR)))
                                                  (TOCELL (fetch (LITATOM DEFINITIONCELL)
                                                             of (CADR PAIR]
                                                 (UNINTERRUPTABLY
                                                     (replace (DEFINITIONCELL DEFPOINTER)
                                                        of TOCELL with (fetch
                                                                                (DEFINITIONCELL
                                                                                 DEFPOINTER)
                                                                                  of FROMCELL))
                                                     (replace (DEFINITIONCELL DEFCELLFLAGS)
                                                        of TOCELL with (fetch
                                                                                (DEFINITIONCELL
                                                                                 DEFCELLFLAGS)
                                                                                  of FROMCELL))
                                                     (replace (DEFINITIONCELL AUXDEFCELLFLAGS)
                                                        of TOCELL with (fetch
                                                                                (DEFINITIONCELL
                                                                                 AUXDEFCELLFLAGS)
                                                                                  of FROMCELL)))])
)

(ADDTOVAR \MAIKO.MOVDS
          (TRUE \LOCKEDPAGEP)
          (\MAIKO.NEWPAGE \NEWPAGE)
          (\MAIKO.NEWPAGE \DONEWPAGE)
          (NILL \LOCKPAGES)
          (NILL \DOLOCKPAGES)
          (NILL \DOTEMPLOCKPAGES)
          (NILL \TEMPUNLOCKPAGES)
          (NILL \UNLOCKPAGES)
          (NILL \WRITEDIRTYPAGE)
          (NILL \DIRTYBACKGROUND)
          (ZERO \COUNTREALPAGES)
          (NILL \SHOWPAGETABLE)
          (NILL CHECKPAGEMAP)
          (EVQ \PAGEFAULT)
          (EVQ \LOADVMEMPAGE)
          (NILL \LOADVMEMPAGE)
          (TRUE \MOVEVMEMFILEPAGE)
          (TRUE \VALIDADDRESSP))
(DEFINEQ

(\DOVE.FAULTINIT
  [LAMBDA NIL                                                (* ; "Edited 18-Sep-87 16:01 by bvm:")
    (DECLARE (GLOBALVARS \RCLKMILLISECOND \RCLKSECOND))
    (SETQ \VMEMACCESSFN (FUNCTION \DOVE.ACTONVMEMFILE))
    (SETQ \IOCBPAGE (create POINTER
                           PAGE# _ \VP.IOCBS))
    (COND
       ((NOT (.VMEM.CONSISTENTP.))
        (\MP.ERROR \MP.INVALIDVMEM)))
    (SETMAINTPANEL 1188)
    (\DL.NEWFAULTINIT)
    (SETMAINTPANEL 1189)
    (SETQ \RCLKMILLISECOND \DOVE.RCLKMILLISECOND)
    (SETQ.NOREF \RCLKSECOND (LOCF (fetch RCLKSECOND of \MISCSTATS)))
                                                             (* ; 
                                                    "Unfortunately, \DOVE.RCLKSECOND is not smallp")
    (replace (FIXP HINUM) of \RCLKSECOND with (CONSTANT (\HINUM \DOVE.RCLKSECOND)))
    (replace (FIXP LONUM) of \RCLKSECOND with (CONSTANT (\LONUM \DOVE.RCLKSECOND)))
    (\RCLK (LOCF (fetch BASECLOCK of \MISCSTATS)))   (* ; "Reset base clock")
    (\DoveMisc.ReadGMT (LOCF (fetch SECONDSCLOCK of \MISCSTATS)))
    (SETMAINTPANEL 1190)
    (\PUTBASEPTR (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS))
           0 NIL)                                            (* ; "Clear the milliseconds timer")
    (\DoveMisc.ReadHostID (LOCF (fetch NSHost0 of \InterfacePage)))
    (SETMAINTPANEL 1191)
    [SETQ \LASTVMEMFILEPAGE (COND
                               (NIL                          (* ; "For now, don't assume vmem is any bigger than the part in use now.  Local file system init will set it to the truth.")
                                    (SETQ \VMEM.FULL.STATE 0)(* ; "Flag to keep pages from being written off the end.  Setting it now prevents bogus vmem full interrupt at startup time.")
                                    (fetch (IFPAGE NActivePages) of \InterfacePage))
                               (T                            (* ; 
                                                           "Microcode is supposed to fill this in")
                                  (fetch (IFPAGE DLLastVmemPage) of \InterfacePage]
    (\DoveDisk.Init)
    (SETMAINTPANEL 1192)
    (\DoveDisplay.TurnOn])

(\DL.FAULTINIT
  [LAMBDA NIL                                                (* bvm%: "20-Oct-86 18:22")
    (SETQ \VMEMACCESSFN (FUNCTION \DL.ACTONVMEMFILE))
    (SETQ \IOCBPAGE (create POINTER
                           PAGE# _ \VP.IOCBS))
    (COND
       ((NOT (.VMEM.CONSISTENTP.))
        (\MP.ERROR \MP.INVALIDVMEM)))
    (\DL.NEWFAULTINIT)
    (SETQ \RCLKMILLISECOND \DLION.RCLKMILLISECOND)           (* ; 
                                                           "These are fortunately both small")
    (SETQ \RCLKSECOND \DLION.RCLKSECOND)
    (\RCLK (LOCF (fetch BASECLOCK of \MISCSTATS)))   (* ; "Reset base clock")
    [COND
       ((EQ (fetch DLTODVALID of \IOPAGE)
            0)                                               (* ; 
                                                       "Time not valid, so store zero in the clock")
        (\PUTBASEPTR (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
               0 NIL))
       (T (bind TMP (BASE _ (LOCF (fetch SECONDSCLOCK of \MISCSTATS)))
             do                                          (* ; 
                        "Loop until clock reads the same as we wrote, in case it was being updated")
                   (\PUTBASE BASE 1 (SETQ TMP (fetch DLTODLO of \IOPAGE)))
                   (\PUTBASE BASE 0 (fetch DLTODHI of \IOPAGE))
             repeatuntil (EQ (fetch DLTODLO of \IOPAGE)
                                 TMP]
    (\PUTBASEPTR (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS))
           0 NIL)                                            (* ; "Clear the milliseconds timer")
    (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE)
                           \DL.PROCESSORBUSY))               (* ; "Wait for IOP readiness")
    (replace DLPROCESSORCMD of \IOPAGE with \DL.READPID)
                                                             (* ; 
                                                        "Ask it to give the processor ID (3 words)")
    (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE)
                           \DL.PROCESSORBUSY))
    (replace NSHost0 of \InterfacePage with (fetch DLPROCESSOR0 of \IOPAGE))
    (replace NSHost1 of \InterfacePage with (fetch DLPROCESSOR1 of \IOPAGE))
    (replace NSHost2 of \InterfacePage with (fetch DLPROCESSOR2 of \IOPAGE))
    (SETQ \LASTVMEMFILEPAGE (fetch (IFPAGE DLLastVmemPage) of \InterfacePage))
    (\DL.DISKINIT T])

(\DL.NEWFAULTINIT
  [LAMBDA NIL                                                (* ; "Edited 21-Oct-87 15:40 by bvm:")

    (* ;; "We have just started up on a DLion or Daybreak.  Boot code has loaded the first n pages of the sysout into pages 2 thru n-3, except for the area covered by the map and IO page, and has built the map accordingly.  Our principal task is to build \REALPAGETABLE")

    (PROG ((NREALPAGES (fetch (IFPAGE NRealPages) of \InterfacePage))
           (FIRSTBUFFERRP \RP.STARTBUFFERS)
           (SCRATCHVP \VP.INITSCRATCH)
           (SCRATCHBASE (create POINTER
                               PAGE# _ \VP.INITSCRATCH))
           FIRSTUSEFULRP IFPAGERP IOCBRP RPTBASE VP RPTPAGES FIRSTRP NDISPLAYPAGES)
          [do (COND
                     ((for I from 0 to (SUB1 \DLBUFFERPAGES)
                         as (FPBASE _ (\ADDBASE \FPTOVP (DLFPFROMRP FIRSTBUFFERRP)))
                         by (\ADDBASE FPBASE 1)
                         do (COND
                                   ([OR (NOT (fetch FPOCCUPIED of FPBASE))
                                        (\LOCKEDPAGEP (SETQ VP (fetch FPVIRTUALPAGE
                                                                      of FPBASE]

                                    (* ;; "Can't use as buffer.  This is just a check for consistency;  you should pick \RP.STARTBUFFERS so that this isn't a problem")

                                    (RETURN T)))             (* ; 
                                                     "Unmap this page so we can use it for buffers")
                               (\WRITEMAP VP 0 \VMAP.VACANT))(* ; "Bad starting place, try again")
                      (add FIRSTBUFFERRP 1))
                     (T (RETURN]
          (SETQ FIRSTUSEFULRP (+ FIRSTBUFFERRP \DLBUFFERPAGES))
          (PROGN                                             (* ; 
                                                      "Copy vital info that booting left in page 1")
                 [COND
                    ((EQ \MACHINETYPE \DAYBREAK)

                     (* ;; "Use first buffer page for IOCB page.  Used to have to place this in a real page whose page-in-segment number was the same as that of \VP.IOCBS, but that constraint is now lifted for Daybreak.")

                     (SETQ IOCBRP FIRSTBUFFERRP)
                     (add FIRSTBUFFERRP 1))
                    (T (SETQ IOCBRP (+ (LOGAND (SUB1 (IMIN NREALPAGES 3072))
                                              65280)
                                       \VP.IOCBS))

                       (* ;; "Put IOCB page near the end of memory, but in the first 1.5 mb so that Burdock can see it.  Temporary until Steve fixes swap code to not care what RP contains IOCB's")

                       [SETQ VP (fetch FPVIRTUALPAGE of (\ADDBASE \FPTOVP (DLFPFROMRP IOCBRP]
                       (COND
                          ((\LOCKEDPAGEP VP)
                           (\MP.ERROR \MP.IOCBPAGE))
                          (T                                 (* ; 
                                                           "Unmap whoever lived in our target page")
                             (\WRITEMAP VP 0 \VMAP.VACANT]
                 (\WRITEMAP \VP.IOCBS IOCBRP \VMAP.CLEAN)
                 (\WRITEMAP SCRATCHVP 1 \VMAP.CLEAN)
                 (\BLT \IOCBPAGE SCRATCHBASE WORDSPERPAGE))
          (PROGN                                             (* ; 
                                                           "Copy InterfacePage out of segment zero")
                 (\WRITEMAP SCRATCHVP FIRSTBUFFERRP \VMAP.CLEAN)
                 (\BLT SCRATCHBASE \InterfacePage WORDSPERPAGE)
                 (\WRITEMAP \VP.IFPAGE (SETQ IFPAGERP FIRSTBUFFERRP)
                        \VMAP.CLEAN)
                 (add FIRSTBUFFERRP 1))
          [PROGN                                             (* ; 
                                                "Unmap everything that fell somewhere we can't use")
                 (\DL.UNMAPPAGES (ADD1 \FP.IFPAGE)
                        (DLFPFROMRP \RP.IOPAGE))             (* ; 
                                                           "real segment zero, map or IOPAGE")
                 (COND
                    ((EQ \MACHINETYPE \DANDELION)
                     (for NEXTBANK0 from 2MBPAGES by 2MBPAGES
                        until (> NEXTBANK0 NREALPAGES) do 

                                           (* ;; "All the `shadows of the display bank' in higher memory have restricted use;  take them out of commission for now")

                                                                 (\DL.UNMAPPAGES NEXTBANK0
                                                                        (+ NEXTBANK0 PAGESPERSEGMENT
                                                                           -1]
          (PROGN                                             (* ; "Copy Display into segment zero")
                 [SETQ NDISPLAYPAGES (COND
                                        ((EQ \MACHINETYPE \DANDELION)

                                 (* ;; "Only lock the standard screen's worth of pages on DLion, even if there are more because the sysout came from wide Daybreak.  Only this many need to be in the display bank, besides which there is a cursor bank after the display;  the rest can be vanilla locked pages.")

                                         \NP.DISPLAY)
                                        (T (IMAX \NP.DISPLAY (ADD1 \MaxScreenPage]
                                                             (* ; 
                                                     "Number of display pages in use in this image")
                 (for I from 0 to (SUB1 NDISPLAYPAGES)
                    do (\WRITEMAP (+ SCRATCHVP I)
                                  (+ \RP.DISPLAY I)
                                  \VMAP.CLEAN))              (* ; 
                                                          "Point scratch area at real segment zero")
                 (\BLT SCRATCHBASE (create POINTER
                                          PAGE# _ \VP.DISPLAY)
                       (UNFOLD NDISPLAYPAGES WORDSPERPAGE))  (* ; 
                                                           "Copy display from wherever boot put it")
                 (for I from 0 to (SUB1 NDISPLAYPAGES)
                    do (\WRITEMAP (+ SCRATCHVP I)
                                  0 \VMAP.VACANT)
                          (\WRITEMAP (+ \VP.DISPLAY I)
                                 (+ \RP.DISPLAY I)
                                 \VMAP.CLEAN))               (* ; 
                                        "Display is now where hardware wants it, so enable display")
                 (replace (IOPAGE DLDISPCONTROL) of \IOPAGE with 0))
          (COND
             ((EQ \MACHINETYPE \DAYBREAK)                    (* ; 
   "If on a daybreak, map the I/O region.  Have to do this before calling \DoveDisplay.ScreenWidth")
              (for I from 0 to (SUB1 \DOVEIORGNSIZE) do (\WRITEMAP (+ \VP.DOVEIORGN I
                                                                                      )
                                                                               (+ \RP.DOVEIORGN I)
                                                                               \VMAP.CLEAN))
              (\DoveIO.InitializeIORegionPtrs)))
          [PROG ((RPSIZE (- NREALPAGES (SETQ \RPOFFSET -1)))
                 (FIRSTVP \VP.RPT))
                (SETQ FIRSTRP (COND
                                 ((OR (> NDISPLAYPAGES \NP.DISPLAY)
                                      (AND (EQ \MACHINETYPE \DAYBREAK)
                                           (EQ (\DoveDisplay.ScreenWidth)
                                               \WIDEDOVEDISPLAYWIDTH)))

                                  (* ;; "Sysout was made on a large screen daybreak, or is now being run on one.  Need to make sure there is space for all that display")

                                  \RP.AFTERDOVEDISPLAY)
                                 (T \RP.AFTERDISPLAY)))      (* ; 
                                      "Construct real page table in segment zero after the display")
                [COND
                   ((> RPSIZE (CONSTANT (EXPT 2 15)))        (* ; 
        "We only have 15 bits for real page table numbers, so have to sacrifice the rest of memory")
                    (SETQ RPSIZE (CONSTANT (EXPT 2 15]
                [SETQ RPTPAGES (PROGN 

                                 (* ;; "This is a way of computing (FOLDHI RPSIZE*3 WORDSPERPAGE) that won't overflow when memory exceeds 10.6MB -- the first term computes RPSIZE*3/256, the second performs the FOLDHI directly on the now much smaller remainder.")

                                      (+ (TIMES3 (FOLDLO RPSIZE WORDSPERPAGE))
                                         (FOLDHI (TIMES3 (IMOD RPSIZE WORDSPERPAGE))
                                                WORDSPERPAGE]
                (COND
                   ((> (+ RPTPAGES FIRSTRP)
                       PAGESPERSEGMENT)

                    (* ;; "No space in bank zero, so put RPT in first segment after 2 megabytes, where the first `shadow' display bank lives.  No shadow bank on Daybreak, but this is as good a place as any")

                    (SETQ FIRSTRP (IMIN 2MBPAGES (- NREALPAGES RPTPAGES)))
                                                             (* ; 
                            "IMIN because we could be on a wide-display Daybreak with small memory")
                    [COND
                       ((> (+ FIRSTVP RPTPAGES)
                           \VP.BUFFERS)                      (* ; 
                                                   "Move virtual assignment backwards if necessary")
                        (SETQ FIRSTVP (COND
                                         ((< RPTPAGES \VP.BUFFERS)
                                          (- \VP.BUFFERS RPTPAGES))
                                         ((<= RPTPAGES PAGESPERSEGMENT)
                                                             (* ; 
                      "Can't fit real page table in display bank at all, so overlap smallneg space")
                                          (UNFOLD \SmallNegHi PAGESPERSEGMENT))
                                         (T                  (* ; 
                                    "Ack, more than 10.6 MB, have to slop over into smallpos space")
                                            (- (+ (UNFOLD \SmallNegHi PAGESPERSEGMENT)
                                                  PAGESPERSEGMENT)
                                               RPTPAGES]
                    (\DL.UNMAPPAGES (DLFPFROMRP FIRSTRP)
                           (DLFPFROMRP (+ FIRSTRP RPTPAGES -1)))
                                                             (* ; 
"Unmap the pages in which RPT lives.  This was already done on DLion, but can't hurt to do it again")
                    ))
                (for I from 0 to (SUB1 RPTPAGES) do 
                                                             (* ; 
                                                           "Assign pages to real page table now")
                                                                   (\WRITEMAP (+ FIRSTVP I)
                                                                          (+ FIRSTRP I)
                                                                          \VMAP.CLEAN))
                (SETQ \REALPAGETABLE (create POINTER
                                            PAGE# _ FIRSTVP))
                (\CLEARWORDS \REALPAGETABLE RPSIZE)
                (\CLEARWORDS (\ADDBASE \REALPAGETABLE RPSIZE)
                       RPSIZE)
                (\CLEARWORDS (\ADDBASE (\ADDBASE \REALPAGETABLE RPSIZE)
                                    RPSIZE)
                       RPSIZE)                               (* ; 
                                  "Clear table in three steps, since 3*RPSIZE overflows after 10MB")
                (SETQ \RPTSIZE RPSIZE)
                (COND
                   [(EQ \MACHINETYPE \DANDELION)
                    (for NEXTBANK0 from 2MBPAGES by 2MBPAGES
                       until (> NEXTBANK0 NREALPAGES) do 
                                                             (* ; 
                                                   "Mark the shadow display bank pages unavailable")
                                                                (\DL.MARK.PAGES.UNAVAILABLE
                                                                 NEXTBANK0
                                                                 (+ NEXTBANK0 PAGESPERSEGMENT -1]
                   (T 
                      (* ;; "RPT itself occupies unavailable pages;  on DLion these were marked unavailable either in segment zero after display or as part of shadow bank")

                      (\DL.MARK.PAGES.UNAVAILABLE FIRSTRP (+ FIRSTRP RPTPAGES -1))
                                                             (* ; 
                                                           "Also, Dove IO region is unavailable")
                      (\DL.MARK.PAGES.UNAVAILABLE \RP.DOVEIORGN (SUB1 (+ \RP.DOVEIORGN 
                                                                             \DOVEIORGNSIZE]
          (PROGN 
                 (* ;; "Fill in special cases in RPT -- the display, which is not where FPTOVP says it is, and all the pages that are unavailable for one reason or another.  Note: any page marked unavailable here MUST be unmapped by now, either because booting never put it where FPTOVP says it would be, there's no page there to begin with, or there's an explicit call to \WRITEMAP or \DL.UNMAPPAGES to unmap it above")

                 (SETQ RPTBASE \REALPAGETABLE)
                 [for I from 0 to (SUB1 NDISPLAYPAGES)
                    do (SETQ RPTBASE (\ADDBASE RPTBASE \RPTENTRYLENGTH)) 
                                                             (* ; "Fill in Display pages")
                          (replace (RPT VP) of RPTBASE with (+ \VP.DISPLAY I))
                          (replace (RPT FILEPAGE) of RPTBASE with (DLFPFROMRP
                                                                               (+ \RP.TEMPDISPLAY I]
                 (\DL.MARK.PAGES.UNAVAILABLE NDISPLAYPAGES \RP.IOPAGE)
                                                             (* ; 
                                        "Mark rest of segment zero plus Map and IOPAGE unavailable")
                 )
          [PROGN                                             (* ; 
                                                       "fill in main part of RPT by reading FPTOVP")
                 (for I from (ADD1 \RP.IOPAGE) to (SUB1 NREALPAGES)
                    as [FPBASE _ (\ADDBASE \FPTOVP (DLFPFROMRP (ADD1 \RP.IOPAGE]
                    by (\ADDBASE FPBASE 1) as [RPTBASE _ (fetch RPTRBASE
                                                                    of (RPTFROMRP (ADD1 
                                                                                           \RP.IOPAGE
                                                                                            ]
                    by (\ADDBASE RPTBASE \RPTENTRYLENGTH)
                    bind (LASTREALPAGE _ (DLRPFROMFP (fetch (IFPAGE NActivePages)
                                                            of \InterfacePage)))
                    do 

                          (* ;; "Fill in rest of RPT from \FPTOVP.  Could optimize this a little by special casing the area occupied by the display, but this is simpler")

                          (COND
                             ((fetch (RPT UNAVAILABLE) of RPTBASE))
                             ((AND (<= I LASTREALPAGE)
                                   (fetch FPOCCUPIED of FPBASE)
                                   [NOT (fetch (VMEMFLAGS VACANT)
                                           of (\READFLAGS (SETQ VP (fetch FPVIRTUALPAGE
                                                                          of FPBASE]
                                   (EQ I (\READRP VP)))

                              (* ;; "There is a VP assigned to this filepage, and it is still there.  False for display that got moved and any real pages that didn't get filled.  LASTREALPAGE is in case the real memory is larger than the sysout -- FPTOVP does not exist all the way")

                              (replace (RPT VP) of RPTBASE with VP)
                              (replace (RPT FILEPAGE) of RPTBASE with (DLFPFROMRP I)))
                             (T (replace (RPT EMPTY) of RPTBASE with T]
          (PROGN                                             (* ; 
                                                           "Touch up RPT with the exceptions")
                 (SETQ RPTBASE (fetch RPTRBASE of (RPTFROMRP IFPAGERP)))
                                                             (* ; "Interface Page")
                 (replace (RPT VP) of RPTBASE with \VP.IFPAGE)
                 (replace (RPT FILEPAGE) of RPTBASE with \FP.IFPAGE)
                 (replace (RPT UNAVAILABLE) of (fetch RPTRBASE of (RPTFROMRP IOCBRP))
                    with T)                              (* ; "\IOCBPAGE")
                 (\DL.MARK.PAGES.UNAVAILABLE FIRSTBUFFERRP (SUB1 FIRSTUSEFULRP))
                                                             (* ; 
                                                           "buffer pages unavailable to swapper")
                 )
          (\CHAIN.UP.RPT)
          (PROG ((NBUFFERS (- FIRSTUSEFULRP FIRSTBUFFERRP))) (* ; "Allocate buffers")
                (for I from 0 to (SUB1 NBUFFERS) do (\WRITEMAP (+ \VP.BUFFERS I)
                                                                           (+ FIRSTBUFFERRP I)
                                                                           \VMAP.CLEAN))
                (\DL.ASSIGNBUFFERS (create POINTER
                                              PAGE# _ \VP.BUFFERS)
                       NBUFFERS])

(\DL.UNMAPPAGES
  [LAMBDA (FIRSTFP LASTFP)                                   (* bvm%: "14-Jan-84 14:20")

(* ;;; 
"At initialization time, unmap anything that originally lived in filepages FIRSTFP thru LASTFP")

    (for FP from FIRSTFP to LASTFP as (FPBASE _ (\ADDBASE \FPTOVP FIRSTFP))
       by (\ADDBASE FPBASE 1) when (fetch FPOCCUPIED of FPBASE)
       do (\WRITEMAP (fetch FPVIRTUALPAGE of FPBASE)
                     0 \VMAP.VACANT])

(\DL.MARK.PAGES.UNAVAILABLE
  [LAMBDA (FIRSTRP LASTRP)                                   (* bvm%: "14-Jan-84 14:32")
    (for I from FIRSTRP to LASTRP as (RPTBASE _ (fetch RPTRBASE
                                                                   of (RPTFROMRP FIRSTRP)))
       by (\ADDBASE RPTBASE \RPTENTRYLENGTH) do (replace (RPT UNAVAILABLE) of RPTBASE
                                                           with T])

(\DL.ASSIGNBUFFERS
  [LAMBDA (BASE NPAGES)                                      (* bvm%: "29-Jan-85 19:05")
    (PROGN                                                   (* ; 
                    "Allocate a page to hold name and password, and perhaps other ephemeral things")
           (\CLEARWORDS BASE WORDSPERPAGE)
           (replace (IFPAGE UserNameAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 1
                                                                                            )))
           (replace (IFPAGE UserPswdAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 
                                                                                            33)))
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -1))
    (PROGN                                                   (* ; "Assign swap buffer")
           (SETQ \EMBUFBASE BASE)
           (SETQ \EMBUFVP (fetch (POINTER PAGE#) of BASE))
           (SETQ \EMBUFRP (\READRP \EMBUFVP))
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -1))
    (PROGN                                                   (* ; "Assign ether buffers")
           (replace (IFPAGE MDSZoneLength) of \InterfacePage with (UNFOLD 2 WORDSPERPAGE)
                  )
           (replace (IFPAGE MDSZone) of \InterfacePage with (\LOLOC BASE))
           (SETQ BASE (\ADDBASE BASE (UNFOLD 2 WORDSPERPAGE)))
           (SETQ \TELERAIDBUFFER BASE)
           (SETQ BASE (\ADDBASE BASE WORDSPERPAGE))
           (add NPAGES -3))
    (PROGN                                                   (* ; "Divvy up buffer space")
           (SETQ \#SWAPBUFFERS (SETQ \#EMUBUFFERS NPAGES))
           (SETQ \#DISKBUFFERS 0)
           (SETQ \EMUSWAPBUFFERS (SETQ \EMUBUFFERS BASE])

(\CHAIN.UP.RPT
  [LAMBDA NIL                                                (* bvm%: "18-Dec-84 16:07")

(* ;;; "Maps over the Real Page Table as constructed so far and fleshes it out.  Assumes that the table is built, has all its VP and FILEPAGE entries set, and that the empty and unavailable entries are so marked.  Finishes the job by chaining together the available pages and setting the LOCKED bits")

    (PROG ((RPTBASE \REALPAGETABLE)
           (LASTEMPTY \REALPAGETABLE)
           (LASTUSED (\ADDBASE \REALPAGETABLE 1))
           FIRSTUSED)
          (SETQ FIRSTUSED LASTUSED)

     (* ;; "The `entry' \REALPAGETABLE is a dummy that points to the least recently used entry.  We use the second word of that dummy as a temporary chain head for the used pages, so that we can put all the empty pages at the front of the queue.")

          [for I from 1 to (SUB1 \RPTSIZE)
             do (SETQ RPTBASE (\ADDBASE RPTBASE \RPTENTRYLENGTH))
                   (COND
                      ((fetch (RPT UNAVAILABLE) of RPTBASE))
                      ((fetch (RPT EMPTY) of RPTBASE)
                       (replace (RPT NEXTRP) of LASTEMPTY with I)
                       (replace (RPT LOCKED) of RPTBASE with NIL)
                       (SETQ LASTEMPTY RPTBASE))
                      (T (replace (RPT NEXTRP) of LASTUSED with I)
                         (replace (RPT LOCKED) of RPTBASE with (\LOCKEDPAGEP
                                                                            (fetch (RPT VP)
                                                                               of RPTBASE)))
                         (SETQ LASTUSED RPTBASE]             (* ; 
                                    "Finally, link the end of empty chain to front of in use chain")
          (replace (RPT NEXTRP) of LASTEMPTY with (fetch (RPT NEXTRP) of 
                                                                                            FIRSTUSED
                                                                     ))
          (replace (RPT NEXTRP) of (SETQ \RPTLAST LASTUSED) with \PAGETABLESTOPFLG)
          (replace (RPT UNAVAILABLE) of \REALPAGETABLE with T)
                                                             (* ; "Dummy first entry")
      ])
)



(* ; "Pagefault handler")

(DEFINEQ

(\FAULTHANDLER
  [LAMBDA NIL                                                (* ; "Edited 27-Sep-88 00:47 by jds")
    (PROG NIL
      LP  [OR (AND \DOFAULTINIT (\FAULTINIT))
              (\PAGEFAULT (\VAG2 (LOGAND 255 (fetch (IFPAGE FAULTHI) of \InterfacePage))
                                     (fetch (IFPAGE FAULTLO) of \InterfacePage]
          (\CONTEXTSWITCH \FAULTFXP)
          (GO LP])

(\PAGEFAULT
  [LAMBDA (PTR)                                              (* bvm%: "13-Aug-85 16:38")
    (\CLOCK0 (LOCF (fetch SWAPTEMP0 of \MISCSTATS))) (* ; "Note time of start")
    (PROG ((VP (fetch (POINTER PAGE#) of PTR))
           FLAGS FILEPAGE)
          (COND
             ((fetch (VP INVALID) of VP)             (* ; 
      "Map out of bounds on Dolphin always produces -1 as the vp.  Don't know about other machines")
              (\MP.ERROR \MP.MOB "Page Fault: Map out of bounds" (AND (NEQ VP 65535)
                                                                          PTR)
                     T))
             ([NOT (fetch (VMEMFLAGS VACANT) of (SETQ FLAGS (\READFLAGS VP]
              (\MP.ERROR \MP.RESIDENT "Fault on resident page" PTR T))
             ((EQ (SETQ FILEPAGE (\LOOKUPPAGEMAP VP))
                  0)
              (\INVALIDADDR PTR))
             (T (COND
                   ((EQ (\HILOC PTR)
                        \STACKHI)                            (* ; 
                                                           "should never happen.  For debugging")
                    (\MP.ERROR \MP.STACKFAULT "Fault on stack" PTR T)))
                (\LOADVMEMPAGE VP FILEPAGE)))
          (COND
             (\NEWVMEMPAGEADDED                              (* ; 
                                                           "Only happens if VMEM.PURE.STATE on")
                    (\ASSURE.FPTOVP.PAGE)))
          [\BOXIPLUS (LOCF (fetch SWAPWAITTIME of \MISCSTATS))
                 (\BOXIDIFFERENCE (\CLOCK0 (LOCF (fetch SWAPTEMP1 of \MISCSTATS)))
                        (LOCF (fetch SWAPTEMP0 of \MISCSTATS]
                                                             (* ; "Count the time used.")
          (RETURN PTR])

(\INVALIDADDR
  [LAMBDA (ADDR)                                             (* bvm%: " 6-AUG-83 22:25")
    (\MP.ERROR \MP.INVALIDADDR "Invalid address" ADDR T])

(\INVALIDVP
  [LAMBDA (VP)                                               (* bvm%: " 6-AUG-83 22:25")
    (\MP.ERROR \MP.INVALIDVP "Invalid VP" VP])

(\FLUSHPAGE
  [LAMBDA (RPTINDEX FROMFLUSHVM)                             (* bvm%: "13-Aug-85 16:35")

(* ;;; "Write out real page RPTINDEX if it is dirty.")

    (PROG ((RPTR (fetch RPTRBASE of RPTINDEX))
           VP FP NEWFP)
          (COND
             ([AND (fetch (RPT OCCUPIED) of RPTR)
                   (fetch (VMEMFLAGS DIRTY) of (\READFLAGS (SETQ VP (fetch (RPT VP)
                                                                               of RPTR]
                                                             (* ; "Yes, page is dirty")
              (SETQ FP (fetch (RPT FILEPAGE) of RPTR))
              [COND
                 [(AND \VMEM.PURE.LIMIT (NOT FROMFLUSHVM))   (* ; 
                                "Don't sully vmem;  write page out beyond the original end of vmem")
                  (COND
                     ((ILEQ FP \VMEM.PURE.LIMIT)
                      (COND
                         ((fetch (RPT LOCKED) of RPTR)
                          (\MP.ERROR \MP.WRITING.LOCKED.PAGE)))
                      (SETQ NEWFP (add (fetch NActivePages of \InterfacePage)
                                         1))
                      (COND
                         ((IGREATERP NEWFP (IDIFFERENCE \LASTVMEMFILEPAGE \GUARDVMEMFULL))
                          (\SET.VMEM.FULL.STATE)))
                      (SETQ \NEWVMEMPAGEADDED T)
                      (\PUTBASE (.PAGEMAPBASE. VP)
                             0 NEWFP)
                      (\PUTBASE \FPTOVP NEWFP VP)
                      (\PUTBASE \FPTOVP FP \NO.VMEM.PAGE)
                      (replace (RPT FILEPAGE) of RPTR with (SETQ FP NEWFP]
                 ((.VMEM.CONSISTENTP.)
                  (replace (IFPAGE Key) of \InterfacePage with (LOGNOT16 \IFPValidKey))
                                                             (* ; 
                                                 "Invalidate vmem and write out the Interface page")
                  (SETQ \DIRTYPAGEHINT 0)                    (* ; 
                                                "So that the dirty page background writer wakes up")
                  (PROG ((IFVP (fetch (POINTER PAGE#) of \InterfacePage)))
                        (\TRANSFERPAGE IFVP \FirstVmemBlock (RPTFROMRP (\READRP IFVP))
                               T NIL]                        (* ; "Write it out")
              (COND
                 ((IGREATERP \DIRTYPAGEHINT 0)
                  (add \DIRTYPAGEHINT -1)))
              (\TRANSFERPAGE VP FP RPTINDEX T NIL])

(\LOADVMEMPAGE
  [LAMBDA (VPAGE FILEPAGE NEWPAGEFLG LOCK? DONTMOVETOPFLG)   (* bvm%: "10-Aug-85 18:08")

    (* ;; "Fault in virtual page VPAGE known to live in FILEPAGE on the vmem.  NEWPAGEFLG is true if the page is new, so should just be cleared, not loaded from vmem file.  If LOCK?  is true, locks down the page as well.  In this case, if on Dandelion, we also check for page wanting to live in a particular real page.  If DONTMOVETOPFLG is true, the real page we put this page in is not promoted to the front of the LRU queue of pages")

    (COND
       ((IGREATERP \PAGEFAULTCOUNTER \UPDATECHAINFREQ)
        (\UPDATECHAIN)))
    (add \PAGEFAULTCOUNTER 1)
    (PROG ((RPTINDEX (\SELECTREALPAGE FILEPAGE LOCK? DONTMOVETOPFLG))
           RPTBASE SPECIALRP)
          (SETQ RPTBASE (fetch RPTRBASE of RPTINDEX))
          [COND
             ((AND LOCK? (OR (EQ \MACHINETYPE \DANDELION)
                             (EQ \MACHINETYPE \DAYBREAK))
                   (SETQ SPECIALRP (\SPECIALRP VPAGE)))  (* ; 
"Must actually put FILEPAGE into special RP, and thus move old contents of SPECIALRP into RPTINDEX")
              (LET* ((SRINDEX (RPTFROMRP SPECIALRP))
                     (SRPTR (fetch RPTRBASE of SRINDEX)))
                    (\MOVEREALPAGE SRINDEX SRPTR RPTINDEX RPTBASE)
                    (SETQ RPTINDEX SRINDEX)
                    (SETQ RPTBASE SRPTR]                     (* ; 
                                                       "Fill in new RPTINDEX with appropriate data")
          (replace (RPT VP) of RPTBASE with VPAGE)
          (replace (RPT FILEPAGE) of RPTBASE with FILEPAGE)
          (replace (RPT LOCKED) of RPTBASE with LOCK?)
          (COND
             ([AND DOLOCKCHECKS (NOT LOCK?)
                   (EQ (LRSH VPAGE 8)
                       (CONSTANT (\HILOC \PAGEMAP]
              (\MP.ERROR \MP.MAPNOTLOCKED "Page of page map being loaded but not locked" VPAGE)))
          (\TRANSFERPAGE VPAGE FILEPAGE RPTINDEX NIL NEWPAGEFLG])

(\MOVEREALPAGE
  [LAMBDA (SOURCEINDEX SOURCERPT DESTINDEX DESTRPT)          (* bvm%: "14-Aug-85 13:53")

(* ;;; "Moves the page, if any, currently living in real page table SOURCEINDEX & SOURCERPT into the page indicated by DESTINDEX & DESTRPT.  The destination is assumed to have been vacated")

    (CHECK (NOT (fetch (RPT LOCKED) of SOURCERPT)))
    (replace (RPT LOCKED) of DESTRPT with NIL)
    [COND
       ((fetch (RPT OCCUPIED) of SOURCERPT)          (* ; 
                                                           "Page was not vacant to start with")
        (LET* ((SOURCEVP (fetch (RPT VP) of SOURCERPT))
               (SOURCEFLAGS (\READFLAGS SOURCEVP)))
              (replace (RPT VP) of DESTRPT with SOURCEVP)
              (replace (RPT FILEPAGE) of DESTRPT with (fetch (RPT FILEPAGE)
                                                                     of SOURCERPT))
              (\WRITEMAP \EMBUFVP (RPFROMRPT DESTINDEX)
                     0)                                      (* ; "Map buffer to target page")
              (\BLT \EMBUFBASE (create POINTER
                                      PAGE# _ SOURCEVP)
                    WORDSPERPAGE)                            (* ; "move data to buffer page")
              (\WRITEMAP \EMBUFVP \EMBUFRP 0)                (* ; 
                                                           "Restore buffer to its proper page")
              (\WRITEMAP SOURCEVP (RPFROMRPT DESTINDEX)
                     SOURCEFLAGS)                            (* ; "Set flags and new RP for page")
              ]
    DESTINDEX])

(\LOOKUPPAGEMAP
  [LAMBDA (VP)                                               (* bvm%: "20-Oct-86 18:26")

    (* ;; "Returns the pagemap entry for VP, which is expected to be in bounds.  High bit of result is the lock bit.  Zero denotes absence")

    (LET [(PRIMENTRY (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP]
         (COND
            ((EQ PRIMENTRY \EMPTYPMTENTRY)
             0)
            (T (\GETBASE \PAGEMAP (IPLUS PRIMENTRY (fetch (VP SECONDARYKEY) of VP])

(\VALIDADDRESSP
  [LAMBDA (BASE)                                             (* bvm%: "16-Jun-86 11:30")
    (NEQ 0 (\LOOKUPPAGEMAP (fetch (POINTER PAGE#) of BASE])

(\LOCKEDPAGEP
  [LAMBDA (VP TEMP)                                          (* bvm%: "18-Feb-85 18:08")

(* ;;; "True if VP is locked.  If TEMP is NIL consults only the locked page table;  otherwise, also checks for `temporary' locked page")

    (OR (NEQ 0 (LOGAND (.LOCKEDVPMASK. VP)
                      (\GETBASE (.LOCKEDVPBASE. VP)
                             0)))
        (UNLESSRDSYS (AND TEMP (NOT (fetch (VMEMFLAGS VACANT) of (\READFLAGS VP)))
                          (fetch (RPT LOCKED) of (fetch RPTRBASE
                                                            of (RPTFROMRP (\READRP VP])

(\SELECTREALPAGE
  [LAMBDA (NEWFP LOCK? DONTMOVETOPFLG)                       (* bvm%: "10-Aug-85 18:08")

    (* ;; "Selects a real page, flushing it if necessary, and returns the RPT index of the page.  NEWFP, if supplied, is the filepage that will be read into here.  This might influence page choice by minimizing seek time.  LOCK?  means caller intends to lock the page, which constrains which real pages it can fall into.  The selected page is moved to the back of the LRU queue, so that it won't be selected again soon, unless DONTMOVETOPFLG is true.  If DONTMOVETOPFLG is REMOVE then the page is spliced out of the chain forever.")

    (PROG ((TRIES 0)
           (CNTR \MAXCLEANPROBES)
           (DISTANCE \MINSHORTSEEK)
           PREVRPT PREVINDEX RPTINDEX RPTBASE FP FLAGS)
      RETRY
          (SETQ PREVRPT \REALPAGETABLE)
          (until (EQ (SETQ RPTINDEX (fetch (RPT NEXTRP) of PREVRPT))
                         \PAGETABLESTOPFLG)
             do (SETQ RPTBASE (fetch RPTRBASE of RPTINDEX))
                   [COND
                      ((fetch (RPT EMPTY) of RPTBASE)
                       (RETURN PREVRPT))
                      ((NOT (fetch (RPT OCCUPIED) of RPTBASE))
                       (\MP.ERROR \MP.CHAIN.UNAVAIL "UNAVAILABLE page on Chain"))
                      ([AND (NOT (fetch (RPT LOCKED) of RPTBASE))
                            [NOT (fetch (VMEMFLAGS REFERENCED)
                                    of (SETQ FLAGS (\READFLAGS (fetch (RPT VP) of RPTBASE
                                                                          ]
                            (OR (NOT LOCK?)
                                (.LOCKABLERP. (RPFROMRPT RPTINDEX]

                       (* ;; "Page is unlocked and unreferenced, so is good candidate for flushing.  LOCK?  check is to avoid locking a page into a real page that might be desired by code that cares about real pages")

                       (COND
                          ([OR (NOT (fetch (VMEMFLAGS DIRTY) of FLAGS))
                               (PROGN (SETQ FP (fetch (RPT FILEPAGE) of RPTBASE))
                                      (COND
                                         ((SELECTQ \VMEM.INHIBIT.WRITE
                                              (NIL [SELECTQ \VMEM.FULL.STATE
                                                       (NIL  (* ; "Normal, can write anything")
                                                            T)
                                                       (T    (* ; 
                                                     "Vmem is full and clean, don't write anything")
                                                          NIL)
                                                       (PROGN 
                                                             (* ; 
              "Vmem is full, but sullied, so might as well write anything for which there is space")
                                                              (AND (ILEQ FP \LASTVMEMFILEPAGE)
                                                                   (OR (NULL \VMEM.PURE.LIMIT)
                                                                       (IGREATERP FP \VMEM.PURE.LIMIT
                                                                              ])
                                              (NEW           (* ; 
      "Only allowed to write old pages, since new pages might just have to get moved a second time")
                                                   (ILEQ FP \VMEM.PURE.LIMIT))
                                              (PROGN         (* ; 
                                                           "We are forbidden from writing any page")
                                                     NIL))
                                          (COND
                                             ((OR (ILEQ CNTR 0)
                                                  (NULL NEWFP)
                                                  (ILESSP (IABS (IDIFFERENCE FP NEWFP))
                                                         DISTANCE))
                                                             (* ; 
                               "Page is near replacement, or we have given up trying for closeness")
                                              T)
                                             (T              (* ; 
                                                       "Page is too far away from replacement page")
                                                (SETQ CNTR (SUB1 CNTR))
                                                [COND
                                                   ((ILESSP DISTANCE \MAXSHORTSEEK)
                                                             (* ; "Get more liberal")
                                                    (SETQ DISTANCE (LLSH DISTANCE 1]
                                                NIL]
                           [COND
                              (DOLOCKCHECKS (COND
                                               ((fetch (RPT LOCKED) of RPTBASE)
                                                (\MP.ERROR \MP.FLUSHLOCKED 
                                                       "Attempt to displace locked page" RPTBASE))
                                               ((EQ (fetch (RPT VPSEG) of RPTBASE)
                                                    (CONSTANT (\HILOC \PAGEMAP)))
                                                (\MP.ERROR \MP.MAPNOTLOCKED 
                                                       "A page of the page map is not locked" RPTBASE
                                                       ]
                           (\FLUSHPAGE RPTINDEX)
                           (\WRITEMAP (fetch (RPT VP) of RPTBASE)
                                  0 \VMAP.VACANT)
                           (replace (RPT EMPTY) of RPTBASE with T)
                           (RETURN PREVRPT]
                   (SETQ PREVRPT RPTBASE)
                   (SETQ PREVINDEX RPTINDEX) finally 

                                 (* ;; "Couldn't find an unreffed page because all pages were touched since last \UPDATECHAIN.  Do another, which clears ref bits, and try again")

                                                   (COND
                                                      ((EQ TRIES 0)
                                                       (SETQ TRIES 1)
                                                       (\UPDATECHAIN))
                                                      [(AND (EQ TRIES 1)
                                                            \VMEM.INHIBIT.WRITE)
                                                       (SETQ \VMEM.INHIBIT.WRITE)
                                                       (COND
                                                          ((AND (NEQ \MACHINETYPE \DANDELION)
                                                                (NEQ \MACHINETYPE \DAYBREAK))

                                 (* ;; "Don't call RAID on a DLion, since the interface is so bad.  Dorado user might want to know that we're smashing \VMEM.INHIBIT.WRITE")

                                                           (RAID 
                                      "No clean vmem pages to reuse, must write one.  ^N to continue"
                                                                 ]
                                                      (T (\MP.ERROR \MP.SELECTLOOP 
                                                                "Loop in \SELECTREALPAGE")))
                                                   (GO RETRY))
          (SELECTQ DONTMOVETOPFLG
              (NIL                                           (* ; 
                           "Move this page to head of chain, so that it won't be picked again soon")
                   (replace (RPT NEXTRP) of PREVRPT with (fetch (RPT NEXTRP)
                                                                        of RPTBASE))
                                                             (* ; "Splice RPTINDEX out of chain")
                   (replace (RPT NEXTRP) of \RPTLAST with RPTINDEX)
                                                             (* ; "Put new page at end of chain")
                   (replace (RPT NEXTRP) of (SETQ \RPTLAST RPTBASE) with 
                                                                                  \PAGETABLESTOPFLG))
              (REMOVE                                        (* ; 
                                                         "Splice this page out of chain altogether")
                      (replace (RPT NEXTRP) of PREVRPT with (fetch (RPT NEXTRP)
                                                                           of RPTBASE))
                      (replace (RPT NEXTRP) of RPTBASE with \PAGETABLESTOPFLG))
              NIL)
          (RETURN RPTINDEX])

(\SPECIALRP
  [LAMBDA (VP)                                               (* edited%: " 9-Aug-85 17:14")

    (* ;; "for \DANDELION, some virtual pages must be mapped into special real pages.  This function returns the corresponding real page")

    (SELECTC (FOLDLO VP PAGESPERSEGMENT)
        ((FOLDLO \VP.STACK PAGESPERSEGMENT) 
             (IPLUS VP (IDIFFERENCE \RP.STACK \VP.STACK)))
        ((FOLDLO \VP.DISPLAY PAGESPERSEGMENT) 
             (IPLUS VP (IDIFFERENCE \RP.DISPLAY \VP.DISPLAY)))
        NIL])

(\TRANSFERPAGE
  [LAMBDA (VP FILEPAGE RPTINDEX WRITE? NEWPAGE?)             (* MPL "27-Jul-85 21:28")

    (* ;; "Transfers virtual page VP between page FILEPAGE of the vmem and real page RPTINDEX.  WRITE?  indicates direction of transfer.  If NEWPAGE?, then page does not exist on file, and is simply cleared")

    (PROG (NEWFLAGS)
          (COND
             (WRITE? (FLIPCURSORBAR 15))
             (T (FLIPCURSORBAR 0)))
          (SETQ NEWFLAGS (COND
                            (NEWPAGE? \VMAP.DIRTY)
                            (WRITE? (LOGAND (\READFLAGS VP)
                                           (LOGNOT16 \VMAP.DIRTY)))
                            (T 0)))
          (COND
             ((AND WRITE? (fetch (RPT LOCKED) of (fetch RPTRBASE of RPTINDEX)))

              (* ;; "Writing a locked page: can't diddle map, because others might die, so do this in the straightforward way")

              (\BLT \EMBUFBASE (create POINTER
                                      PAGE# _ VP)
                    WORDSPERPAGE)                            (* ; 
                                                 "Copy page into buffer, then write the buffer out")
              (\ACTONVMEMFILE FILEPAGE \EMBUFBASE 1 T)
              (SETQ \LASTACCESSEDVMEMPAGE FILEPAGE))
             ((NOT NEWPAGE?)                                 (* ; 
        "Map the buffer page into the target real page, read/write the page, then set the map back")
              (\WRITEMAP VP 0 \VMAP.VACANT)                  (* ; 
                      "Unmap VP so that we don't have two virtual pages pointing at same real page")
              (\WRITEMAP \EMBUFVP (RPFROMRPT RPTINDEX)
                     0)                                      (* ; "Map buffer to target page")
              (\ACTONVMEMFILE FILEPAGE \EMBUFBASE 1 WRITE?)
                                                             (* ; "Do the i/o")
              (\WRITEMAP \EMBUFVP \EMBUFRP 0)                (* ; 
                                                           "Restore buffer to its proper page")
              (SETQ \LASTACCESSEDVMEMPAGE FILEPAGE)))
          (\WRITEMAP VP (RPFROMRPT RPTINDEX)
                 NEWFLAGS)                                   (* ; "Set flags for page")
          (COND
             (NEWPAGE?                                       (* ; 
             "Not on file yet, so clear it.  Couldn't do this sooner because the flags weren't set")
                    (\CLEARWORDS (create POINTER
                                        PAGE# _ VP)
                           WORDSPERPAGE)))
          (COND
             (WRITE? (FLIPCURSORBAR 15)
                    (\BOXIPLUS (LOCF (fetch SWAPWRITES of \MISCSTATS))
                           1))
             (T (FLIPCURSORBAR 0)
                (\BOXIPLUS (LOCF (fetch PAGEFAULTS of \MISCSTATS))
                       1])

(\UPDATECHAIN
  [LAMBDA NIL                                                (* bvm%: "30-Jul-85 15:20")
                                                             (* ; 
                                                           "Sorts the page chain by reference bit")
    (CHECK (NOT \INTERRUPTABLE))
    (PROG ((RPTINDEX (fetch (RPT NEXTRP) of \REALPAGETABLE))
           (CHAIN0 \REALPAGETABLE)
           (CHAIN1 (\ADDBASE \REALPAGETABLE 2))
           RPTR VP FLAGS HEAD1)
          (SETQ HEAD1 CHAIN1)

     (* ;; "HEAD1 = CHAIN1 is just a holding cell for the second Chain we temporarily create inside here.  Use the unused third word of the dummy header entry of \REALPAGETABLE")

          (replace (RPT NEXTRP) of CHAIN0 with \PAGETABLESTOPFLG)
          (replace (RPT NEXTRP) of CHAIN1 with \PAGETABLESTOPFLG)
          (do (SETQ RPTR (fetch RPTRBASE of RPTINDEX))
                 (SETQ VP (fetch (RPT VP) of RPTR))
                 [SETQ FLAGS (COND
                                ((fetch (RPT EMPTY) of RPTR)
                                 0)
                                (T (\READFLAGS VP]
                 (COND
                    ((OR (fetch (RPT LOCKED) of RPTR)
                         (PROGN (COND
                                   ([AND DOLOCKCHECKS (EQ (fetch (RPT VPSEG) of RPTR)
                                                          (CONSTANT (\HILOC \PAGEMAP]
                                    (\MP.ERROR \MP.MAPNOTLOCKED 
                                           "A page of the page map is not locked" RPTR)))
                                (fetch (VMEMFLAGS REFERENCED) of FLAGS)))
                                                             (* ; 
                                                         "Page referenced or locked, put on CHAIN1")
                     (\WRITEMAP VP (RPFROMRPT RPTINDEX)
                            (LOGAND FLAGS (LOGNOT16 \VMAP.REF)))
                                                             (* ; "Turn off ref bit")
                     (replace (RPT NEXTRP) of CHAIN1 with RPTINDEX)
                     (SETQ CHAIN1 RPTR))
                    (T                                       (* ; 
                                                  "Page was not referenced recently, put on CHAIN0")
                       (replace (RPT NEXTRP) of CHAIN0 with RPTINDEX)
                       (SETQ CHAIN0 RPTR)))
                 (SETQ RPTINDEX (fetch (RPT NEXTRP) of RPTR)) 
                                                             (* ; "Look at next page in old chain")
             repeatuntil (EQ RPTINDEX \PAGETABLESTOPFLG))
          (replace (RPT NEXTRP) of CHAIN1 with \PAGETABLESTOPFLG)
                                                             (* ; "End of the line")
          (replace (RPT NEXTRP) of CHAIN0 with (fetch (RPT NEXTRP) of HEAD1))
                                                             (* ; 
                                                        "Link end of CHAIN0 to beginning of CHAIN1")
          (SETQ \RPTLAST (COND
                            ((EQ HEAD1 CHAIN1)               (* ; "Nothing on CHAIN1 ??!!")
                             CHAIN0)
                            (T CHAIN1)))                     (* ; 
                                                           "Pointer to end of complete chain")
          (SETQ \DIRTYPAGECOUNTER (SETQ \PAGEFAULTCOUNTER 0])
)



(* ; "Allocating and locking new pages")

(DEFINEQ

(\NEWPAGE
  [LAMBDA (BASE NOERROR LOCK?)                               (* ; 
                                                      "Edited 24-Oct-92 12:45 by sybalsky:mv:envos")

(* ;;; "Creates and returns a new page located at virtual addr BASE")

    (* ;; "If LOCK?, lock the page into real memory (A NOP on nonXerox machines!)")

    (UNINTERRUPTABLY
        (COND
           [(NOT (\MISCAPPLY* (FUNCTION \DONEWPAGE)
                        BASE LOCK?))                         (* ; "Failed, page exists")
            (COND
               ((NOT NOERROR)
                (\MP.ERROR \MP.NEWPAGE "Attempt to allocate already existing page" BASE T)))
            (COND
               (LOCK? (\LOCKPAGES BASE 1]
           ((IGREATERP (fetch (IFPAGE NActivePages) of \InterfacePage)
                   (IDIFFERENCE \LASTVMEMFILEPAGE \GUARDVMEMFULL))
                                                             (* ; "Vmem getting full!")
            (\SET.VMEM.FULL.STATE)))
        BASE)])

(\DONEWPAGE
  [LAMBDA (BASE LOCK? INTERNALFLG)                           (* bvm%: "13-Aug-85 16:32")

(* ;;; "Allocates new page at BASE, locking it if LOCK?  is true.  Returns vmemfile page# on success, NIL if page already exists.  Must be run in safe context! because it can cause vmem activity")

    (AND \DOFAULTINIT (\FAULTINIT))                      (* ; 
              "Only an issue when INIT.SYSOUT starts.  Perhaps there is a better place to put this")
    (PROG ((VP (fetch (POINTER PAGE#) of BASE))
           MAPBASE LOCKBASE FILEPAGE NEXTPM ERRCODE)
          (RETURN (COND
                     ((fetch (VP INVALID) of VP)
                      (\INVALIDVP VP)
                      NIL)
                     (T (SETQ MAPBASE (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)))
                        (COND
                           ((EQ MAPBASE \EMPTYPMTENTRY)      (* ; 
                                                          "Need to create a new second-level block")
                            (SETQ NEXTPM (fetch (IFPAGE NxtPMAddr) of \InterfacePage))
                            [COND
                               ((EVENP NEXTPM WORDSPERPAGE)

                                (* ;; "Need a new secondary pagemap page.  This recursion is ok, because we know that SETUPPAGEMAP assures that the pagemap pages for all the pages in secondary map space were created at MAKEINIT time")

                                (OR (\DONEWPAGE (\ADDBASE \PAGEMAP NEXTPM)
                                           T T)
                                    (RETURN (\MP.ERROR \MP.NEWMAPPAGE 
                                                   "\DONEWPAGE failed to allocate new map page"]
                            (\PUTBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)
                                   NEXTPM)
                            (replace (IFPAGE NxtPMAddr) of \InterfacePage
                               with (IPLUS NEXTPM \PMblockSize))
                            (SETQ MAPBASE NEXTPM)))
                        [SETQ MAPBASE (\ADDBASE \PAGEMAP (IPLUS MAPBASE (fetch (VP SECONDARYKEY)
                                                                           of VP]
                        (COND
                           ((NEQ (\GETBASE MAPBASE 0)
                                 0)                          (* ; "Page exists")
                            (RETURN NIL)))
                        (SETQ FILEPAGE (add (fetch (IFPAGE NActivePages) of 
                                                                                       \InterfacePage
                                                       )
                                              1))
                        (replace (IFPAGE NDirtyPages) of \InterfacePage with FILEPAGE)
                                                             (* ; "Currently a redundant field")
                        [COND
                           (LOCK? (SETQ FILEPAGE (\MAKESPACEFORLOCKEDPAGE VP FILEPAGE))
                                  (\PUTBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP))
                                         0
                                         (LOGOR (.LOCKEDVPMASK. VP)
                                                (\GETBASE LOCKBASE 0]
                        (\PUTBASE \FPTOVP FILEPAGE VP)
                        (\PUTBASE MAPBASE 0 FILEPAGE)
                        (\LOADVMEMPAGE VP FILEPAGE T LOCK?)
                        (COND
                           (INTERNALFLG (SETQ \NEWVMEMPAGEADDED T))
                           (T                                (* ; 
                                                          "Make sure \FPTOVP extended if necessary")
                              (\ASSURE.FPTOVP.PAGE)))
                        FILEPAGE])

(\ASSURE.FPTOVP.PAGE
  [LAMBDA NIL                                                (* bvm%: "13-Aug-85 16:29")

    (* ;; "Called at the end of some swapping operation that added one or more pages to the vmem file, setting \NEWVMEMPAGEADDED true.  If we're going to need a new page of \FPTOVP soon, do it now while there's still maneuvering room.  The allowance below is for the worst case, which can happen when VMEM.PURE.STATE is on and \NEWPAGE was called needing a new pagemap page as well, in which case we could have as many as the following new vmem pages before we're home safe --- 1: \NEWPAGE added a page --- 2: a page was displaced by the new page and written to the end of the vmem --- 3: a new pagemap page was needed --- 4: it displaced a page to end of vmem --- 5: the new \FPTOVP page below --- 6: a page displaced by same.  --- --- Alternatively, it could have been the new \FPTOVP page that needed a new pagemap block.  Will never have both needing a new pagemap block, since there are several pagemap blocks per page")

    (LET ((FILEPAGE (fetch (IFPAGE NActivePages) of \InterfacePage)))
         (COND
            ((IGREATERP (IMOD FILEPAGE WORDSPERPAGE)
                    (IDIFFERENCE WORDSPERPAGE 7))            (* ; 
                                           "This is a no-op if the page has already been allocated")
             (\DONEWPAGE (\ADDBASE \FPTOVP (CEIL FILEPAGE WORDSPERPAGE))
                    T T)))
         (SETQ \NEWVMEMPAGEADDED NIL])

(\MAKESPACEFORLOCKEDPAGE
  [LAMBDA (VP FILEPAGE)                                      (* bvm%: "29-Jun-86 17:44")

    (* ;; "VP is a page to be locked, FILEPAGE its home.  Returns a possibly new file page where VP will now live, after having kicked the former resident of the new file page into VP's old FILEPAGE")

    (PROG (DESIREDFP OLDVP FPBASE)
          [SETQ DESIREDFP (SELECTC (FOLDLO VP PAGESPERSEGMENT)
                              ((FOLDLO \VP.STACK PAGESPERSEGMENT) 
                                   (IPLUS VP (IDIFFERENCE (DLFPFROMRP \RP.STACK)
                                                    \VP.STACK)))
                              ((FOLDLO \VP.DISPLAY PAGESPERSEGMENT) 
                                                             (* ; 
                        "Display lives in a fixed place in file, but does not land there initially")
                                   (IPLUS VP (IDIFFERENCE (DLFPFROMRP \RP.TEMPDISPLAY)
                                                    \VP.DISPLAY)))
                              ((FOLDLO \VP.FPTOVP PAGESPERSEGMENT) 
                                                             (* ; 
                         "A new page of FPTOVP has to be continguous on file with other such pages")
                                   (IPLUS VP (IDIFFERENCE (DLFPFROMRP \RP.FPTOVP)
                                                    \VP.FPTOVP)))
                              (COND
                                 ((AND (ILEQ FILEPAGE (fetch LastLockedFilePage of 
                                                                                       \InterfacePage
                                                             ))
                                       (IGREATERP FILEPAGE (DLFPFROMRP \RP.MISCLOCKED)))
                                                             (* ; 
                     "Page is in a good place already.  It probably was once locked, then unlocked")
                                  (RETURN FILEPAGE))
                                 (T                          (* ; 
                                                          "Put it after all the other locked pages")
                                    (add (fetch LastLockedFilePage of \InterfacePage)
                                           1]
          (COND
             ((AND (fetch FPOCCUPIED of (SETQ FPBASE (\ADDBASE \FPTOVP DESIREDFP)))
                   (NEQ (SETQ OLDVP (fetch FPVIRTUALPAGE of FPBASE))
                        VP))                                 (* ; 
                                                          "Someone else lives here, so move it out")
              (\MOVEVMEMFILEPAGE OLDVP DESIREDFP FILEPAGE)))
          (RETURN DESIREDFP])

(\MOVEVMEMFILEPAGE
  [LAMBDA (VP OLDFP NEWFP)                                   (* bvm%: "18-Nov-84 14:14")
    (PROG ((FLAGS (\READFLAGS VP))
           RP)
          (COND
             ((fetch (VMEMFLAGS VACANT) of FLAGS)    (* ; 
                                                           "Page not resident, so pull it in")
              (\LOADVMEMPAGE VP OLDFP)
              (SETQ FLAGS \VMAP.CLEAN))
             ((\LOCKEDPAGEP VP)
              (\MP.ERROR \MP.BADLOCKED "Locked page is in the way" VP)))
          (\WRITEMAP VP (SETQ RP (\READRP VP))
                 (LOGOR FLAGS \VMAP.DIRTY))                  (* ; 
                           "Mark page dirty, so that it will eventually be written to its new home")
          (replace (RPT FILEPAGE) of (fetch RPTRBASE of (RPTFROMRP RP)) with
                                                                                        NEWFP)
                                                             (* ; "Tell RPT where VP now lives")
          (\PUTBASE (.PAGEMAPBASE. VP)
                 0 NEWFP)                                    (* ; "Tell \PAGEMAP about it")
          (\PUTBASE \FPTOVP NEWFP VP)                        (* ; "...  and \FPTOVP")
      ])

(\NEWEPHEMERALPAGE
  [LAMBDA (BASE NOERROR)                                     (* bvm%: "26-NOV-82 15:40")

(* ;;; "Creates and returns a new page located at virtual addr BASE, mapping it permanently into some real page but leaving it out of the vmem file")

    (\MISCAPPLY* (FUNCTION \DONEWEPHEMERALPAGE)
           BASE NOERROR])

(\DONEWEPHEMERALPAGE
  [LAMBDA (BASE NOERROR)                                     (* bvm%: "30-Oct-86 16:47")

(* ;;; "Creates and returns a new page located at virtual addr BASE, mapping it permanently into some real page but leaving it out of the vmem file")

    (LET ((VP (fetch (POINTER PAGE#) of BASE))
          MAPBASE PREVRP RPTINDEX RPTR)
         (COND
            ((fetch (VP INVALID) of VP)
             (\INVALIDVP VP)
             NIL)
            ([OR (AND (NEQ (SETQ MAPBASE (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY)
                                                                  of VP)))
                           \EMPTYPMTENTRY)
                      (NEQ (\GETBASE \PAGEMAP (IPLUS MAPBASE (fetch (VP SECONDARYKEY)
                                                                of VP)))
                           0))
                 (NOT (fetch (VMEMFLAGS VACANT) of (\READFLAGS VP]
                                                             (* ; 
                                                          "Page is in the vmem already, so no hope")
             (COND
                ((NOT NOERROR)
                 (\MP.ERROR \MP.NEWPAGE "Page already exists " BASE T)))
             BASE)
            (T (COND
                  ((IGREATERP \PAGEFAULTCOUNTER \UPDATECHAINFREQ)
                   (\UPDATECHAIN)))
               (add \PAGEFAULTCOUNTER 1)
               (SETQ RPTINDEX (\SELECTREALPAGE NIL T 'REMOVE))
                                                             (* ; "Find a page to put this in")
               (SETQ RPTR (fetch RPTRBASE of RPTINDEX))
                                                             (* ; 
                                                       "Fill in new RPTINDEX with appropriate data")
               (replace (RPT VP) of RPTR with \RPT.UNAVAILABLE)
               (replace (RPT FILEPAGE) of RPTR with VP)
                                                             (* ; "For debugging only")
               (FLIPCURSORBAR 0)
               (\WRITEMAP VP (RPFROMRPT RPTINDEX)
                      \VMAP.DIRTY)                           (* ; "Set flags for page")
               (\CLEARWORDS (create POINTER
                                   PAGE# _ VP)
                      WORDSPERPAGE)                          (* ; "Clear new page")
               (FLIPCURSORBAR 0)
               (\BOXIPLUS (LOCF (fetch PAGEFAULTS of \MISCSTATS))
                      1)
               (COND
                  (\NEWVMEMPAGEADDED (\ASSURE.FPTOVP.PAGE)))
               BASE])

(\LOCKPAGES
  [LAMBDA (BASE NPAGES)                                      (* bvm%: "26-NOV-82 15:17")

    (* ;; "Needs to be done in safe stack context because might cause vmem transfer")

    (\MISCAPPLY* (FUNCTION \DOLOCKPAGES)
           BASE NPAGES)
    BASE])

(\DOLOCKPAGES
  [LAMBDA (BASE NPAGES)                                      (* ; "Edited 21-Oct-87 15:49 by bvm:")
    (for I from 0 to (SUB1 NPAGES) bind (VP _ (fetch (POINTER PAGE#) of
                                                                                         BASE))
                                                     FILEPAGE MAPBASE RPTBASE RPINDEX RP MASK 
                                                     LOCKBASE
       do [COND
                 ((fetch (VP INVALID) of VP)
                  (\INVALIDVP VP))
                 [(EQ (SETQ MAPBASE (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)))
                      \EMPTYPMTENTRY)
                  (\INVALIDADDR (ADDBASE BASE (UNFOLD I WORDSPERPAGE]
                 (T [SETQ MAPBASE (\ADDBASE \PAGEMAP (IPLUS MAPBASE (fetch (VP SECONDARYKEY)
                                                                       of VP]
                    (SETQ FILEPAGE (\GETBASE MAPBASE 0))
                    (COND
                       ((EQ 0 (LOGAND (SETQ MASK (.LOCKEDVPMASK. VP))
                                     (\GETBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP))
                                            0)))             (* ; "Not locked yet")
                        (COND
                           ((fetch VACANT of (\READFLAGS VP))
                                                             (* ; 
                                       "Bring locked page into core so we can move it if necessary")
                            (\LOADVMEMPAGE VP FILEPAGE NIL T)))
                        [SETQ RPINDEX (RPTFROMRP (SETQ RP (\READRP VP]
                        (SETQ RPTBASE (fetch RPTRBASE of RPINDEX))
                        [COND
                           ((AND (NOT (.LOCKABLERP. RP))
                                 (NOT (\SPECIALRP VP)))

                            (* ;; "Page already swapped in, but lives in a real page that might need to get bumped (e.g., for stack), so move it now.  If \SPECIALRP is true then we know that the page got swapped into the right place, so no need to move it.")

                            (LET* ((NEWINDEX (\SELECTREALPAGE NIL T))
                                   (NEWRPT (fetch RPTRBASE of NEWINDEX)))
                                  (\MOVEREALPAGE RPINDEX RPTBASE NEWINDEX NEWRPT)
                                  (replace (RPT EMPTY) of RPTBASE with T)
                                                             (* ; "Mark vacated RPT entry empty")
                                  (SETQ RPTBASE NEWRPT)
                                  (SETQ RP (RPFROMRPT NEWINDEX]
                        (COND
                           ((NEQ FILEPAGE (SETQ FILEPAGE (\MAKESPACEFORLOCKEDPAGE VP FILEPAGE)))

                            (* ;; "Moving to a new page, so have to mark this locked page dirty so that it will eventually get written to its new home")

                            (\WRITEMAP VP RP (LOGOR \VMAP.DIRTY \VMAP.REF))
                            (replace (RPT FILEPAGE) of RPTBASE with FILEPAGE)
                            (\PUTBASE \FPTOVP FILEPAGE VP)
                            (\PUTBASE MAPBASE 0 FILEPAGE)))
                        (\PUTBASE LOCKBASE 0 (LOGOR MASK (\GETBASE LOCKBASE 0)))
                                                             (* ; "Set lock bit in page map")
                        (replace (RPT LOCKED) of RPTBASE with T]
             (add VP 1) finally (COND
                                           (\NEWVMEMPAGEADDED 
                                                             (* ; 
        "If we had to load or rearrange pages, vmem could have gotten bigger if VMEM.PURE.STATE on")
                                                  (\ASSURE.FPTOVP.PAGE])

(\TEMPLOCKPAGES
  [LAMBDA (BASE NPAGES)                                      (* bvm%: "10-Aug-85 18:17")

(* ;;; "`Temporarily' locks BASE for NPAGES, i.e. ensures that the swapper will not move the pages.  Information vanishes at logout etc.")

    (\MISCAPPLY* (FUNCTION \DOTEMPLOCKPAGES)
           BASE NPAGES])

(\DOTEMPLOCKPAGES
  [LAMBDA (BASE NPAGES)                                      (* ; "Edited 21-Oct-87 15:49 by bvm:")

    (* ;; "`Temporarily' locks BASE for NPAGES, i.e. ensures that the swapper will not move the pages.  Information vanishes at logout etc.  This function must be locked because it manipulates the page table table.  Runs in MISC context")

    (to NPAGES as VP from (fetch (POINTER PAGE#) of BASE) bind RPTBASE 
                                                                                    RPINDEX RP
       do (\TOUCHPAGE BASE)                              (* ; "Touch page in case not resident")
             [SETQ RPINDEX (RPTFROMRP (SETQ RP (\READRP VP]
             (SETQ RPTBASE (fetch RPTRBASE of RPINDEX))
             [COND
                ((NOT (.LOCKABLERP. RP))

                 (* ;; "Page already swapped in, but lives in a real page that might need to get bumped (e.g., for stack), so move it now")

                 (LET* ((NEWINDEX (\SELECTREALPAGE NIL T))
                        (NEWRPT (fetch RPTRBASE of NEWINDEX)))
                       (\MOVEREALPAGE RPINDEX RPTBASE NEWINDEX NEWRPT)
                       (replace (RPT EMPTY) of RPTBASE with T)
                                                             (* ; "Mark vacated RPT entry empty")
                       (SETQ RPTBASE NEWRPT]
             (replace (RPT LOCKED) of RPTBASE with T)
             (SETQ BASE (\ADDBASE BASE WORDSPERPAGE])

(\TEMPUNLOCKPAGES
  [LAMBDA (BASE NPAGES)                                      (* bvm%: "30-Jul-85 16:58")

    (* ;; "Unlocks pages that were locked by \TEMPLOCKPAGES.  This function must be locked because it manipulates the page table")

    (while (IGREATERP NPAGES 0) bind (VP _ (fetch (POINTER PAGE#) of BASE))
                                          RPTR
       do (UNINTERRUPTABLY
                  (\TOUCHPAGE BASE)                          (* ; 
         "Touch page in case not resident.  Should only happen if page wasn't locked to begin with")
                  (COND
                     ((AND (NEQ (SETQ RPTR (\READRP VP))
                                0)
                           (EQ [fetch (RPT VP) of (SETQ RPTR (fetch RPTRBASE
                                                                        of (RPTFROMRP RPTR]
                               VP))
                      (COND
                         ([AND DOLOCKCHECKS (EQ (LRSH VP 8)
                                                (CONSTANT (\HILOC \PAGEMAP]
                          (\MP.ERROR \MP.UNLOCKINGMAP "Attempt to unlock map page" VP)))
                      (replace (RPT LOCKED) of RPTR with NIL))
                     (T (HELP "Page table changed out from under me!" VP))))
             (add VP 1)
             (add NPAGES -1)
             (SETQ BASE (\ADDBASE BASE WORDSPERPAGE])

(\UNLOCKPAGES
  [LAMBDA (BASE NPAGES)                                      (* bvm%: "30-Jul-85 16:58")

(* ;;; "Unlocks NPAGES virtual pages from BASE onward")

    (UNINTERRUPTABLY
        (for I from 0 to (SUB1 NPAGES) bind (VP _ (fetch (POINTER PAGE#)
                                                                     of BASE))
                                                         MASK LOCKBASE
           do (COND
                     ((fetch (VP INVALID) of VP)
                      (\INVALIDVP VP))
                     ((NEQ 0 (LOGAND (SETQ MASK (.LOCKEDVPMASK. VP))
                                    (\GETBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP))
                                           0)))              (* ; 
                                                    "Yes, page was locked, so turn the bit off now")
                      (COND
                         ([AND DOLOCKCHECKS (EQ (LRSH VP 8)
                                                (CONSTANT (\HILOC \PAGEMAP]
                          (\MP.ERROR \MP.UNLOCKINGMAP "Attempt to unlock map page" VP)))
                      (\PUTBASE LOCKBASE 0 (LOGXOR MASK (\GETBASE LOCKBASE 0)))
                                                             (* ; 
                                                      "Update pagemap, then update real page table")
                      (replace (RPT LOCKED) of (fetch RPTRBASE of (RPTFROMRP
                                                                                   (\READRP VP)))
                         with NIL)))
                 (add VP 1)))])
)



(* ; "Writing out the vmem")

(DEFINEQ

(\FLUSHVM
  [LAMBDA (MAIKO.SYSOUTFILE)                             (* ; "Edited 10-Feb-2021 22:43 by lmm")
                                                             (* ; 
                                                           "Edited  6-Jan-89 19:23 by Hayata")

    (* ;; 
  "Writes out all dirty pages to vmem, making it consistent.  Returns NIL now, T  on restart")

    (UNINTERRUPTABLY
        (PROG NIL
              (SELECTQ (\MISCAPPLY* (FUNCTION \DOFLUSHVM)
                              MAIKO.SYSOUTFILE)
                  (NIL (SETQ \DIRTYPAGEHINT 32767)
                       (RETURN NIL))
                  (1 (ERROR "Can not find sysout file"))
                  (2 (ERROR "FILE-SYSTEM-RESOURCES-EXCEEDED"))
                  (3 (ERROR "Can not open sysout file"))
                  (4 (ERROR "Can not seek sysout file"))
                  (5 (ERROR "Can not write sysout file"))
                  (6 (ERROR "Connection timed out"))
                  NIL)
              (SETQ \DOFAULTINIT T)
              (\CONTEXTSWITCH \FAULTFXP)
              (for VAR in \SYSTEMCACHEVARS do (SET VAR NIL))
              (RETURN T)))])

(\LOGOUT0
  [LAMBDA (FAST)                                             (* ; 
                                                           "Edited 18-Jul-88 04:14 by masinter")
    [COND
       ((OR (EQ (fetch MachineType of \InterfacePage)
                \DORADO)
            (EQ (fetch MachineType of \InterfacePage)
                \DOLPHIN))

        (* ;; "If we're running on a Dolphin or Dorado, we update the alto's clock.  Note that Dandelions and Daybreaks don't have alto clocks, so this wouldn't work on them")

        (\BLT (EMADDRESS \RTCSECONDS)
              (LOCF (fetch SECONDSCLOCK of \MISCSTATS))
              (UNFOLD 3 WORDSPERCELL]
    (UNINTERRUPTABLY
        (OR (AND [OR (NOT FAST)
                     (AND (EQ FAST '?)
                          (NOT (.VMEM.CONSISTENTP.]
                 (\FLUSHVM))
            (SELECTC \MACHINETYPE
                (\DAYBREAK (\DoveMisc.BootButton))
                (SUBRCALL LISPFINISH FAST))))])

(\DOFLUSHVM
  [LAMBDA (MAIKO.SYSOUTFILE)                             (* ; "Edited 10-Feb-2021 22:38 by lmm")
                                                             (* ; 
                                                           "Edited  6-Jan-89 19:23 by Hayata")

(* ;;; "Write everything out in a resumable way.  Value is NIL if returned from directly, T if from saved state.  Always invoked via \MISCAPPLY*")

    (CHECK (NOT \INTERRUPTABLE))                             (* ; 
                               "NOTE: need stats gathering off in here.  Also avoid touching pages")
    (PROG ((IFPVP (fetch (POINTER PAGE#) of \InterfacePage))
           (SCRATCHBUF \EMUSWAPBUFFERS)
           IFPRPT)
          (replace (IFPAGE MISCSTACKRESULT) of \InterfacePage with T)
                                                             (* ; 
"This will make it look like we have returned from BCPL if caller gets control from the saved state")

     (* ;; "update interface pge before writing out sysout")

          (replace (IFPAGE CurrentFXP) of \InterfacePage with (fetch (IFPAGE MiscFXP)
                                                                             of \InterfacePage))
          (RETURN (SUBRCALL VMEMSAVE MAIKO.SYSOUTFILE])

(\RELEASEWORKINGSET
  [LAMBDA NIL                                            (* bvm%: "29-Nov-84 10:56")
    (COND
       ((\FLUSHVM)                                       (* ; "Returning from Lisp startup")
        T)
       (T                                                    (* ; "Unmap any unlocked page")
          (for RPTINDEX from 1 to (SUB1 \RPTSIZE) bind RPTR
             when (AND (fetch (RPT OCCUPIED) of (SETQ RPTR (fetch RPTRBASE
                                                                          of RPTINDEX)))
                           (NOT (fetch (RPT LOCKED) of RPTR)))
             do (\WRITEMAP (fetch (RPT VP) of RPTR)
                           (RPFROMRPT RPTINDEX)
                           \VMAP.VACANT)
                   (replace (RPT EMPTY) of RPTR with T])

(\WRITEDIRTYPAGE
  [LAMBDA (MINDIRTY)                                     (* bvm%: "13-Aug-85 17:51")
    (COND
       ((OR (NOT (.VMEM.CONSISTENTP.))
            (AND \VMEM.PURE.LIMIT (NEQ \VMEM.PURE.LIMIT -1)
                 (NOT \VMEM.FULL.STATE)))
        (PROG ((RPTR (OR \LASTDIRTYSCANPTR \REALPAGETABLE))
               (NUMDIRTY (OR \LASTDIRTYCNT 0))
               (CNT \MAXDIRTYSCANCOUNT)
               RP FP FLAGS)
              [COND
                 ((AND (NULL \LASTDIRTYSCANPTR)
                       (IGREATERP (IPLUS (add \DIRTYPAGECOUNTER 1)
                                         \PAGEFAULTCOUNTER)
                              \UPDATECHAINFREQ))             (* ; 
                                                  "Take this time to update the page chain instead")
                  (RETURN (UNINTERRUPTABLY
                              (\MISCAPPLY* (FUNCTION \UPDATECHAIN)))]
              (OR MINDIRTY (SETQ MINDIRTY 1))
          LP  [COND
                 [(EQ (SETQ RP (fetch (RPT NEXTRP) of RPTR))
                      \PAGETABLESTOPFLG)                     (* ; 
                                  "Hit end of chain.  Write out what we found if enough were dirty")
                  (COND
                     ((AND (IGEQ NUMDIRTY MINDIRTY)
                           (NEQ NUMDIRTY 0)
                           (SETQ RP \LASTDIRTYFOUND))
                      (GO GOTPAGE))
                     (T (SETQ \LASTDIRTYSCANPTR (SETQ \LASTDIRTYCNT (SETQ \LASTDIRTYFOUND NIL)))
                        [COND
                           ((AND (NEQ NUMDIRTY 0)
                                 (ILESSP \DIRTYSEEKMAX (LRSH MAX.SMALL.INTEGER 1)))
                                                             (* ; 
                                     "Failed because page not close enough, so widen the tolerance")
                            (SETQ \DIRTYSEEKMAX (LLSH \DIRTYSEEKMAX 1]
                        (RETURN]
                 ((fetch (RPT EMPTY) of (SETQ RPTR (fetch RPTRBASE of RP)))
                                                             (* ; 
                                              "Page is empty.  Should never happen if key is valid")
                  (RETURN))
                 ((NOT (fetch (RPT LOCKED) of RPTR)) (* ; 
            "Don't bother writing out locked pages, since they don't help us in our swapping quest")
                  (SETQ FLAGS (\READFLAGS (fetch (RPT VP) of RPTR)))
                  (COND
                     ((NOT (fetch (VMEMFLAGS DIRTY) of FLAGS))
                                                             (* ; "Page not dirty;  skip")
                      )
                     [(PROGN (SETQ FP (fetch (RPT FILEPAGE) of RPTR))
                             (IGREATERP (IABS (IDIFFERENCE (COND
                                                              ((AND \VMEM.PURE.LIMIT (ILESSP FP 
                                                                                     \VMEM.PURE.LIMIT
                                                                                            ))
                                                             (* ; 
                                                 "We'd have to write page to a new place, not here")
                                                               (fetch (IFPAGE NActivePages)
                                                                  of \InterfacePage))
                                                              (T FP))
                                                     \LASTACCESSEDVMEMPAGE))
                                    \DIRTYSEEKMAX))          (* ; 
                                                           "Page too far away, don't write it")
                      (COND
                         ((fetch (VMEMFLAGS REFERENCED) of FLAGS)
                                                             (* ; "but still count it")
                          (add NUMDIRTY 1]
                     ((IGREATERP FP \LASTVMEMFILEPAGE)       (* ; "Can't write it")
                      )
                     ((fetch (VMEMFLAGS REFERENCED) of FLAGS)
                                                             (* ; 
                           "Page dirty but referenced.  Note it, but keep looking for a better one")
                      (COND
                         ((EQ NUMDIRTY 0)
                          (SETQ \LASTDIRTYFOUND RP)))
                      (add NUMDIRTY 1))
                     (T                                      (* ; "Dirty, not referenced: do it")
                        (GO GOTPAGE]
              (COND
                 ((EQ (add CNT -1)
                      0)                                     (* ; 
                                                    "Scanned for long enough;  don't lock user out")
                  (SETQ \LASTDIRTYSCANPTR RPTR)
                  (SETQ \LASTDIRTYCNT NUMDIRTY)
                  (RETURN)))
              (GO LP)
          GOTPAGE
              (UNINTERRUPTABLY
                  (SETQ \LASTDIRTYSCANPTR (SETQ RPTR (fetch RPTRBASE of RP)))
                                                             (* ; "Keep traveling pointer")
                  (SETQ \LASTDIRTYCNT (SETQ \LASTDIRTYFOUND NIL))
                  (COND
                     ((ILEQ (IABS (IDIFFERENCE (fetch (RPT FILEPAGE) of RPTR)
                                         \LASTACCESSEDVMEMPAGE))
                            \DIRTYSEEKMAX)                   (* ; 
                        "Could fail if swapping since the selection has moved the disk arm too far")
                      (\MISCAPPLY* (FUNCTION \WRITEDIRTYPAGE1)
                             RP RPTR)))
                  (SETQ \DIRTYSEEKMAX \MAXSHORTSEEK))
              (RETURN T])

(\WRITEDIRTYPAGE1
  [LAMBDA (RP RPTR)                                      (* bvm%: "13-Aug-85 16:41")
                                                             (* ; 
                           "Write out buffer RP.  This fn is locked and called in the misc context")
    (COND
       ([AND (NOT (fetch (RPT LOCKED) of RPTR))
             (fetch (VMEMFLAGS DIRTY) of (\READFLAGS (fetch (RPT VP) of RPTR]
                                                             (* ; 
               "Verify that the page is still a candidate, so previous loop could be interruptable")
        (\FLUSHPAGE RP)
        (COND
           (\NEWVMEMPAGEADDED (\ASSURE.FPTOVP.PAGE])

(\COUNTREALPAGES
  [LAMBDA (TYPE)                                         (* bvm%: "18-Dec-84 15:31")
    (SELECTQ TYPE
        ((DIRTY REF) 
             [PROG [(FLAGBITS (COND
                                 ((EQ TYPE 'DIRTY)
                                  \VMAP.DIRTY)
                                 (T \VMAP.REF]
                   (RETURN (NPAGESMACRO (NEQ (LOGAND (\READFLAGS VP)
                                                    FLAGBITS)
                                             0])
        (LOCKED (NPAGESMACRO (fetch (RPT LOCKED) of RPTR)))
        (OCCUPIED (NPAGESMACRO T))
        (\ILLEGAL.ARG TYPE])
)



(* ; "VMEM.PURE.STATE hack")

(DEFINEQ

(\DOCOMPRESSVMEM
  [LAMBDA NIL                                            (* bvm%: " 7-Apr-84 17:53")

(* ;;; "Called underneath \DOFLUSHVM to write the pages above the high water mark back to the places vacated below that mark")

    (PROG ((EMPTYFP (DLFPFROMRP \RP.GCTABLE))
           (LASTFP (fetch NActivePages of \InterfacePage))
           (OLDVIW \VMEM.INHIBIT.WRITE)
           VP)
          [COND
             ((NULL OLDVIW)

              (* ;; "Encourage \SELECTREALPAGE to select only `old' file pages for displacement, so that we don't needlessly write the same page twice")

              (SETQ \VMEM.INHIBIT.WRITE 'NEW]
      LP  (COND
             ((IGEQ EMPTYFP LASTFP)
              (SETQ \VMEM.INHIBIT.WRITE OLDVIW)
              (RETURN)))
          [COND
             ((EQ (\GETBASE \FPTOVP EMPTYFP)
                  \NO.VMEM.PAGE)
              (while (EQ (SETQ VP (\GETBASE \FPTOVP LASTFP))
                             \NO.VMEM.PAGE) do (SETQ LASTFP (SUB1 LASTFP)))
              (\MOVEVMEMFILEPAGE VP LASTFP EMPTYFP)
              (replace NActivePages of \InterfacePage with (SETQ LASTFP (SUB1 LASTFP]
          (add EMPTYFP 1)
          (GO LP])

(VMEM.PURE.STATE
  [LAMBDA FLG                                            (* bvm%: " 7-Apr-84 16:59")
    (PROG1 (NOT (NULL \VMEM.PURE.LIMIT))
        [COND
           ((IGREATERP FLG 0)

            (* ;; "Set \VMEM.PURE.LIMIT appropriately.  If turning on, and it wasn't on before, set it to -1 so that it takes effect only at the next FLUSHVM")

            (SETQ \VMEM.PURE.LIMIT (AND (ARG FLG 1)
                                        (OR \VMEM.PURE.LIMIT (SETQ \VMEM.PURE.LIMIT -1])])
)



(* ;; 
"Handling the backing store getting too full--keep running, but if we overflow, we can never \FLUSHVM because there is no place to write some pages"
)

(DEFINEQ

(32MBADDRESSABLE
  [LAMBDA NIL                                         (* ; "Edited  2-May-88 22:03 by MASINTER")
    (SELECTC \MACHINETYPE
        (\DORADO T)
        (\DOLPHIN NIL)
        (\DAYBREAK T)
        (NEQ 0 (fetch (IFPAGE DL24BitAddressable) of \InterfacePage])

(\SET.VMEM.FULL.STATE
  [LAMBDA NIL                                            (* bvm%: "13-Feb-85 20:12")
                                                             (* ; 
                 "We are running out of vmem, try to extend file.  Do this at next convenient time")
    (COND
       ((NOT \VMEM.FULL.STATE)                               (* ; "Get an interrupt to handle this")
        (replace VMEMFULL of \INTERRUPTSTATE with T)
        (SETQ \PENDINGINTERRUPT T)))
    (SETQ \VMEM.FULL.STATE (COND
                              ((ILESSP (fetch (IFPAGE NActivePages) of \InterfacePage)
                                      \LASTVMEMFILEPAGE)     (* ; 
                                               "Not completely full, allow normal things to happen")
                               0)
                              ((.VMEM.CONSISTENTP.)
                               T)
                              (T 'DIRTY])

(\SET.LASTVMEMFILEPAGE
  [LAMBDA (N)                                            (* ; "Edited  6-Apr-87 14:09 by bvm:")

    (* ;; "Called by disk routines when they discover how long the physical vmem is.  Currently only used by Dove.")

    (COND
       ((IGREATERP (fetch (IFPAGE NActivePages) of \InterfacePage)
               (IDIFFERENCE (SETQ \LASTVMEMFILEPAGE N)
                      \GUARDVMEMFULL))                       (* ; "Vmem getting full!")
        (\SET.VMEM.FULL.STATE))
       (T                                                    (* ; 
                                          "Vmem ok now (was earlier set to full for safety's sake)")
          (SETQ \VMEM.FULL.STATE NIL)))
    N])

(\DOVMEMFULLINTERRUPT
  [LAMBDA NIL                                            (* ; "Edited 21-Oct-87 13:54 by bvm:")

(* ;;; "Called while interruptable when vmem is full or nearly so.  Tries to extend vmem file, or gives error if it can't")

    (COND
       (\EXTENDINGVMEMFILE 

              (* ;; "Another interrupt happened while we are extending file.  Don't try to do this one twice, but repost the interrupt in the hopes that it will happen after vmem extension is finished")

              (SETQ \PENDINGINTERRUPT T))
       (T (RESETVARS ((\EXTENDINGVMEMFILE T))

           (* ;; "Used to have code here that tried to extend the vmem file, but even on those that support extension it's flaky, and rarely what you want--people allocate the vmem file to the desired size in the first place, don't want it extended further.")

                     (PROG ((HELPFLAG 'BREAK!))
                           (replace VMEMFULL of \INTERRUPTSTATE with NIL)
                                                             (* ; 
             "Very slight chance of losing the break if ^E right here.  Don't know how to fix this")
                           (CL:CERROR "Resume the interrupted computation"
                                  (CONCAT "Your virtual memory backing file is "
                                         (COND
                                            ((>= (fetch (IFPAGE NActivePages) of 
                                                                                       \InterfacePage
                                                        )
                                                 \LASTVMEMFILEPAGE)
                                             "complete")
                                            (T "near"))
                                         "ly full.
Save your work & reload a.s.a.p."])

(\FLUSHVMOK?
  [LAMBDA (TYPE NOERROR)                                     (* ; 
                                                           "Edited 10-Feb-2021 21:49 by larry")
                                                             (* bvm%: " 7-Sep-85 10:48")

(* ;;; "Called before any attempt to do a \FLUSHVM to make sure it's ok")

    T])
)

(RPAQ? \UPDATECHAINFREQ 100)

(RPAQ? \PAGEFAULTCOUNTER 0)

(RPAQ? \DIRTYPAGECOUNTER 0)

(RPAQ? \DIRTYPAGEHINT 0)

(RPAQ? \LASTACCESSEDVMEMPAGE 0)

(RPAQ? \MAXSHORTSEEK 1000)

(RPAQ? \MINSHORTSEEK 20)

(RPAQ? \MAXCLEANPROBES 20)

(RPAQ? \VMEM.INHIBIT.WRITE )

(RPAQ? \VMEM.PURE.LIMIT )

(RPAQ? \VMEM.FULL.STATE )

(RPAQ? \GUARDVMEMFULL 500)

(RPAQ? VMEM.COMPRESS.FLG )

(RPAQ? \DOFAULTINIT 0)

(RPAQ? \VMEMACCESSFN )

(RPAQ? \SYSTEMCACHEVARS )

(RPAQ? \MAXSWAPBUFFERS 1)

(RPAQ? \EXTENDINGVMEMFILE )

(RPAQ? \MaxScreenPage 0)

(RPAQ? \NEWVMEMPAGEADDED )

(RPAQ? \LASTDIRTYCNT )

(RPAQ? \LASTDIRTYFOUND )

(RPAQ? \LASTDIRTYSCANPTR )

(RPAQ? \DIRTYSEEKMAX 50)



(* ; "Errors signaled in the maintenance panel")

(DEFINEQ

(\MP.ERROR
  [LAMBDA (CODE STRING ARG1 ARG2)                        (* mpl "20-Jun-85 11:09")
    (COND
       ((OR (EQ \MACHINETYPE \DANDELION)
            (EQ \MACHINETYPE \DAYBREAK))
        ((OPCODES RAID)
         CODE))
       (T (RAID STRING ARG1 ARG2])
)



(* ; "Debugging code.  Some of this also runs renamed for extra TeleRaid help")

(DEFINEQ

(\ACTONVMEMFILE
  [LAMBDA (FILEPAGE BUFFER NPAGES WRITEFLAG)             (* MPL "22-Jun-85 20:18")
    (COND
       ((EQ \MACHINETYPE \DANDELION)
        (\DL.ACTONVMEMFILE FILEPAGE BUFFER NPAGES WRITEFLAG))
       ((EQ \MACHINETYPE \DAYBREAK)
        (\DOVE.ACTONVMEMFILE FILEPAGE BUFFER NPAGES WRITEFLAG))
       (T (\M44ACTONVMEMFILE FILEPAGE BUFFER NPAGES WRITEFLAG])

(\SHOWPAGETABLE
  [LAMBDA (MODE FILE)                                    (* bvm%: "12-Jul-86 16:55")
    (PROG ((*PRINT-BASE* 8)
           (OUTSTREAM (GETSTREAM FILE 'OUTPUT))
           (RPTR \REALPAGETABLE)
           (RP 0)
           FLAGS VP STATE FIRSTONE LASTONE)
          (printout OUTSTREAM "     RP      VP           FilePage  Status" T)
          (until (SELECTQ MODE
                         (CHAIN (EQ (SETQ RP (fetch (RPT NEXTRP) of RPTR))
                                    \PAGETABLESTOPFLG))
                         (NIL (add RP 1)
                              (IGEQ RP \RPTSIZE))
                         (\ILLEGAL.ARG MODE))
             do (SETQ RPTR (fetch RPTRBASE of RP))
                   (SETQ VP (fetch (RPT VP) of RPTR))
                   (COND
                      ((AND (NULL MODE)
                            (EQ VP STATE))
                       (SETQ LASTONE RP))
                      (T (COND
                            (LASTONE (printout OUTSTREAM "ditto thru " LASTONE T)
                                   (SETQ LASTONE NIL)))
                         (SETQ FIRSTONE RP)
                         (SETQ STATE VP)
                         (printout OUTSTREAM |.I7.8| (RPFROMRPT RP))
                         [COND
                            ((fetch (RPT EMPTY) of RPTR)
                             (PRIN1 " Empty" OUTSTREAM))
                            ((NOT (fetch (RPT OCCUPIED) of RPTR))
                             (PRIN1 " Unavailable" OUTSTREAM))
                            (T (printout OUTSTREAM |.I8.8| VP %,)
                               (\PRINTVP VP OUTSTREAM)
                               (printout OUTSTREAM 28 |.I6.8| (fetch (RPT FILEPAGE) of RPTR)
                                      %,,)
                               (COND
                                  ((fetch (RPT LOCKED) of RPTR)
                                   (COND
                                      ((NOT (\LOCKEDPAGEP VP))
                                                             (* ; "not permanently locked")
                                       (PRIN1 "Temp" OUTSTREAM)))
                                   (PRIN1 "Locked " OUTSTREAM)))
                               (UNLESSRDSYS (PROGN (COND
                                                      ((fetch (VMEMFLAGS REFERENCED)
                                                          of (SETQ FLAGS (\READFLAGS VP)))
                                                       (PRIN1 "Ref " OUTSTREAM)))
                                                   (COND
                                                      ((fetch (VMEMFLAGS DIRTY) of FLAGS)
                                                       (PRIN1 "Dirty" OUTSTREAM]
                         (TERPRI OUTSTREAM])

(CHECKPAGEMAP
  [LAMBDA NIL                                            (* bvm%: "12-Jul-86 16:56")
    (LET ((*PRINT-BASE* 8)
          (NUMOCCUPIED 0)
          (NUMLOCKED 0)
          (CHAINOCCUPIED 0)
          (CHAINLOCKED 0)
          RPTR FPBASE FP VP RP)
         (CHECKFPTOVP)
         [for RPTINDEX from 1 to (SUB1 \RPTSIZE)
            when (fetch (RPT OCCUPIED) of (SETQ RPTR (fetch RPTRBASE of RPTINDEX)
                                                       ))
            do (add NUMOCCUPIED 1)
                  (SETQ VP (fetch (RPT VP) of RPTR))
                  (SETQ FP (fetch (RPT FILEPAGE) of RPTR))
                  (COND
                     ((CHECKFPTOVP1 FP VP RPTINDEX))
                     ([NEQ VP (fetch FPVIRTUALPAGE of (SETQ FPBASE (\ADDBASE \FPTOVP FP]
                      (printout T "RPT for RP " (RPFROMRPT RPTINDEX)
                             " says VP ")
                      (\PRINTVP VP T)
                      (printout T " lives in FP " FP "; but FP Map says that FP contains ")
                      (\PRINTVP (fetch FPVIRTUALPAGE of FPBASE)
                             T)
                      (printout T T))
                     ((\LOCKEDPAGEP VP)
                      (add NUMLOCKED 1)
                      (COND
                         ((NOT (fetch (RPT LOCKED) of RPTR))
                          (printout T "VP " VP ", living in RP " (RPFROMRPT RPTINDEX)
                                 " should be locked but isn't." T))
                         ((IGREATERP FP (DLRPFROMFP (fetch (IFPAGE LastLockedFilePage)
                                                       of \InterfacePage)))
                          (printout T "VP " VP " is locked, but living in FP " FP 
                                 ", which is not in the locked page area" T]
         (PROGN (SETQ RPTR \REALPAGETABLE)                   (* ; "Check pagetable chain")
                [while (NEQ (SETQ RP (fetch (RPT NEXTRP) of RPTR))
                                \PAGETABLESTOPFLG) when (fetch (RPT OCCUPIED)
                                                               of (SETQ RPTR
                                                                       (fetch RPTRBASE
                                                                          of RP)))
                   do (add CHAINOCCUPIED 1)
                         (COND
                            ((fetch (RPT LOCKED) of RPTR)
                             (add CHAINLOCKED 1]
                (COND
                   ((ILESSP CHAINOCCUPIED NUMOCCUPIED)
                    (printout T NUMOCCUPIED " occupied pages, but only " CHAINOCCUPIED 
                           " are on page chain.  " NUMLOCKED " pages are permanently locked; " 
                           CHAINLOCKED " pages on chain are locked somehow." T])

(CHECKFPTOVP
  [LAMBDA NIL                                            (* bvm%: "10-Dec-84 12:39")
    (for FP from 1 to (fetch NActivePages of \InterfacePage)
       as (FPBASE _ (\ADDBASE \FPTOVP 1)) by (\ADDBASE FPBASE 1)
       when (fetch FPOCCUPIED of FPBASE) do (CHECKFPTOVP1 FP
                                                                   (fetch FPVIRTUALPAGE
                                                                      of FPBASE])

(CHECKFPTOVP1
  [LAMBDA (FP VP RPTINDEX)                               (* bvm%: "10-Dec-84 12:36")
    (PROG ((FP2 (\LOOKUPPAGEMAP VP)))
          (RETURN (COND
                     ((NEQ FP2 FP)
                      (COND
                         ((UNLESSRDSYS RPTINDEX)
                          (printout T "RPT for RP " (RPFROMRPT RPTINDEX)))
                         (T (printout T "FP map")))
                      (printout T " says FP " FP " contains VP ")
                      (\PRINTVP VP T)
                      (printout T "; but PageMap says that page is in FP " FP2 T)
                      T])

(\PRINTFPTOVP
  [LAMBDA (FIRSTPAGE NWORDS TYPEFLG STREAM VPRAWFLG)     (* bvm%: "24-Sep-86 11:44")
    (SETQ STREAM (GETSTREAM STREAM 'OUTPUT))
    (OR FIRSTPAGE (SETQ FIRSTPAGE 1))
    (OR NWORDS (SETQ NWORDS (fetch (IFPAGE NActivePages) of \InterfacePage)))
    (LET ((BASE (\ADDBASE \FPTOVP (SUB1 FIRSTPAGE)))
          (*PRINT-BASE* 8)
          (LASTVP -2)
          (NEXTFP (SUB1 FIRSTPAGE))
          FIRSTFP FIRSTVP NEXTVP LOCKEDP TYPE NEXTLOCKED NEXTTYPE)
         (while (IGEQ NWORDS 0)
            do (add NEXTFP 1)
                  [COND
                     ((EQ NWORDS 0)
                      (SETQ NEXTVP -1))
                     ((NEQ (SETQ NEXTVP (\GETBASE (SETQ BASE (\ADDBASE BASE 1))
                                               0))
                           \NO.VMEM.PAGE)
                      (SETQ NEXTLOCKED (\LOCKEDPAGEP NEXTVP))
                      (if TYPEFLG
                          then (SETQ NEXTTYPE (TYPENAME (create POINTER
                                                                   PAGE# _ NEXTVP)))
                                (if (NULL NEXTTYPE)
                                    then (SETQ NEXTTYPE (SELECTC (LRSH NEXTVP 8)
                                                                ((LIST \PNAME.HI (CL:1+ \PNAME.HI)) 
                                                                     "Pnames")
                                                                ((LIST \DEF.HI (CL:1+ \DEF.HI)) 
                                                                     "Definitions")
                                                                ((LIST \VAL.HI (CL:1+ \VAL.HI)) 
                                                                     "Value cells")
                                                                ((LIST \PLIST.HI (CL:1+ \PLIST.HI)) 
                                                                     "Property lists")
                                                                ((\HILOC \FPTOVP) 
                                                                     "\FPTOVP")
                                                                (\STACKHI "Stack")
                                                                ((\HILOC \HTMAIN) 
                                                                     "GC Main table")
                                                                ((\HILOC \HTOVERFLOW) 
                                                                     "GC Overflow table")
                                                                NIL]
                  [COND
                     ([COND
                         ((EQ NEXTVP \NO.VMEM.PAGE)
                          (NEQ LASTVP \NO.VMEM.PAGE))
                         (T (OR (NEQ NEXTVP (ADD1 LASTVP))
                                (NEQ NEXTLOCKED LOCKEDP)
                                (NEQ TYPE NEXTTYPE]
                      [COND
                         ((IGEQ LASTVP 0)
                          (COND
                             (FIRSTFP (printout STREAM FIRSTFP "-")))
                          (printout STREAM (SUB1 NEXTFP)
                                 12)
                          (COND
                             ((EQ LASTVP \NO.VMEM.PAGE)
                              (printout STREAM "empty"))
                             (T (COND
                                   (FIRSTFP (if VPRAWFLG
                                                then (PRIN1 FIRSTVP STREAM)
                                              else (\PRINTVP FIRSTVP STREAM))
                                          (PRIN1 "-" STREAM)))
                                (if VPRAWFLG
                                    then (PRIN1 LASTVP STREAM)
                                  else (\PRINTVP LASTVP STREAM))
                                (COND
                                   (LOCKEDP (PRIN1 '* STREAM)))
                                (if TYPE
                                    then (printout STREAM 32 TYPE]
                      (SETQ FIRSTFP)
                      (TERPRI STREAM)
                      (SETQ FIRSTVP NEXTVP))
                     (T                                      (* ; "in a run")
                        (OR FIRSTFP (SETQ FIRSTFP (SUB1 NEXTFP]
                  (SETQ LASTVP NEXTVP)
                  (SETQ LOCKEDP NEXTLOCKED)
                  (SETQ TYPE NEXTTYPE)
                  (add NWORDS -1])

(\PRINTVP
  [LAMBDA (VP STREAM)                                    (* bvm%: "28-MAR-83 12:40")
    (printout STREAM "{" (LRSH VP 8)
           ","
           (LOGAND VP 255)
           "}"])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \ACTONVMEMFILE MACRO ((X . Y)
                                        (SPREADAPPLY* \VMEMACCESSFN X . Y)))

(PUTPROPS .VMEM.CONSISTENTP. MACRO (NIL (EQ (fetch (IFPAGE Key) of \InterfacePage)
                                                    \IFPValidKey)))

(PUTPROPS .LOCKABLERP. MACRO [(RP)
                                      (OR (NEQ (FOLDLO RP PAGESPERSEGMENT)
                                               (FOLDLO \RP.STACK PAGESPERSEGMENT))
                                          (NOT (OR (EQ \MACHINETYPE \DANDELION)
                                                   (EQ \MACHINETYPE \DAYBREAK])
)




(* ; "Virtual page flags")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \VMAP.DIRTY 10000Q)

(RPAQQ \VMAP.CLEAN 0)

(RPAQQ \VMAP.REF 100000Q)

(RPAQQ \VMAP.VACANT 30000Q)

(RPAQQ \VMAP.FLAGS 170000Q)

(RPAQQ \VMAP.NOTFLAGS 7777Q)


(CONSTANTS \VMAP.DIRTY \VMAP.CLEAN \VMAP.REF \VMAP.VACANT \VMAP.FLAGS \VMAP.NOTFLAGS)
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS VMEMFLAGS ((VACANT (EQ (LOGAND DATUM \VMAP.VACANT)
                                      \VMAP.VACANT))
                          (DIRTY (NEQ (LOGAND DATUM \VMAP.DIRTY)
                                      0))
                          (REFERENCED (NEQ (LOGAND DATUM \VMAP.REF)
                                           0))))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS LOGNOT16 MACRO ((X)
                                  (LOGXOR X 177777Q)))
)




(* ; "RPT constants")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \RPT.EMPTY 177776Q)

(RPAQQ \RPT.UNAVAILABLE 177777Q)

(RPAQQ \PAGETABLESTOPFLG 0)

(RPAQQ \RPTENTRYLENGTH 3)


(CONSTANTS \RPT.EMPTY \RPT.UNAVAILABLE \PAGETABLESTOPFLG \RPTENTRYLENGTH)
)
(DECLARE%: EVAL@COMPILE

(BLOCKRECORD RPT ((LOCKED FLAG)
                      (NEXTRP BITS 17Q)
                      (VP WORD)
                      (FILEPAGE WORD))
                     (BLOCKRECORD RPT ((NIL BITS 20Q)
                                       (VPSEG BYTE)
                                       (VPPAGEINSEG BYTE)))
                     [ACCESSFNS RPT ([EMPTY (EQ (fetch (RPT VP) of DATUM)
                                                \RPT.EMPTY)
                                            (COND
                                               (NEWVALUE (replace (RPT VP) of DATUM
                                                            with \RPT.EMPTY))
                                               (T (ERROR "Invalid replace of RPT.EMPTY" DATUM]
                                     [UNAVAILABLE (EQ (fetch (RPT VP) of DATUM)
                                                      \RPT.UNAVAILABLE)
                                            (COND
                                               (NEWVALUE (replace (RPT VP) of DATUM
                                                            with \RPT.UNAVAILABLE))
                                               (T (ERROR "Invalid replace of RPT.UNAVAILABLE" DATUM]
                                     (OCCUPIED (ILESSP (fetch (RPT VP) of DATUM)
                                                      \RPT.EMPTY])

(ACCESSFNS RPT1 (RPTRBASE (\ADDBASE (\ADDBASE \REALPAGETABLE (LLSH DATUM 1))
                                     DATUM)))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS RPFROMRPT MACRO ((RPTINDEX)
                                   (IPLUS RPTINDEX \RPOFFSET)))

(PUTPROPS RPTFROMRP MACRO ((RP)
                                   (IDIFFERENCE RP \RPOFFSET)))

(PUTPROPS NPAGESMACRO MACRO ((FORM)
                                     (PROG ((RESULT 0)
                                            (CNTR \RPTSIZE)
                                            (RPTR \REALPAGETABLE)
                                            VP)
                                       LP  (COND
                                              ((NEQ (SETQ CNTR (SUB1 CNTR))
                                                    0)
                                               (SETQ RPTR (\ADDBASE RPTR \RPTENTRYLENGTH))
                                               (COND
                                                  ((AND (fetch (RPT OCCUPIED) of RPTR)
                                                        (PROGN (SETQ VP (fetch (RPT VP)
                                                                           of RPTR))
                                                               FORM))
                                                   (add RESULT 1)))
                                               (GO LP)))
                                           (RETURN RESULT))))
)




(* ; "Virtual to file pagemap")

(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAXFILEPAGE 177776Q)


(CONSTANTS \MAXFILEPAGE)
)

(* "END EXPORTED DEFINITIONS")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \EMPTYPMTENTRY 177777Q)


(CONSTANTS \EMPTYPMTENTRY)
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS VP ((PRIMARYKEY (LRSH DATUM 5))
                   (SECONDARYKEY (LOGAND DATUM 37Q))
                   (INVALID (PROGN NIL))))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS .PAGEMAPBASE. MACRO [OPENLAMBDA (VPAGE)
                                        (\ADDBASE \PAGEMAP (IPLUS (\GETBASE \PageMapTBL
                                                                         (fetch (VP PRIMARYKEY)
                                                                            of VPAGE))
                                                                  (fetch (VP SECONDARYKEY)
                                                                     of VPAGE])
)




(* ; "FP to VP stuff")

(DECLARE%: EVAL@COMPILE

(BLOCKRECORD FPTOVP ((FPVIRTUALPAGE FIXP))
                        [ACCESSFNS FPTOVP ((FPOCCUPIED (NEQ (\GETBASE DATUM 0)
                                                            \NO.VMEM.PAGE])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \NO.VMEM.PAGE 177777Q)


(CONSTANTS \NO.VMEM.PAGE)
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS DLRPFROMFP MACRO ((FP)
                                    (ADD1 FP)))

(PUTPROPS DLFPFROMRP MACRO ((RP)
                                    (SUB1 RP)))
)


(PUTPROPS \TOUCHPAGE DOPVAL (1 GETBASE.N 0))

(PUTPROPS TIMES3 DOPVAL (1 COPY LLSH1 IPLUS2))




(* ; "Locked page table")

(DECLARE%: EVAL@COMPILE 

(PUTPROPS .LOCKEDVPBASE. MACRO ((VP)
                                        (\ADDBASE \LOCKEDPAGETABLE (FOLDLO VP BITSPERWORD))))

(PUTPROPS .LOCKEDVPMASK. MACRO ((VP)
                                        (LLSH 1 (IMOD VP BITSPERWORD))))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAXDIRTYSCANCOUNT 144Q)

(RPAQQ \MINVMEMSPAREPAGES 144Q)

(RPAQQ \DLBUFFERPAGES 20Q)


(CONSTANTS \MAXDIRTYSCANCOUNT \MINVMEMSPAREPAGES \DLBUFFERPAGES)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ 2MBPAGES 10000Q)


(CONSTANTS 2MBPAGES)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \UPDATECHAINFREQ \REALPAGETABLE \RPTLAST \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE 
       \EMBUFVP \EMBUFRP \PAGEFAULTCOUNTER \LASTDIRTYCNT \LASTDIRTYFOUND \LASTDIRTYSCANPTR 
       \MACHINETYPE \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYSEEKMAX 
       \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE 
       \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP 
       \VMEMACCESSFN \SYSTEMCACHEVARS \LASTVMEMFILEPAGE \EXTENDINGVMEMFILE \MaxScreenPage 
       \NEWVMEMPAGEADDED)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \#SWAPBUFFERS \#EMUBUFFERS \#DISKBUFFERS \MAXSWAPBUFFERS \EMUSWAPBUFFERS \EMUBUFFERS 
       \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS RWMufMan DMACRO ((X)
                                   ((OPCODES 170Q 11Q)
                                    X)))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ DOLOCKCHECKS NIL)


(CONSTANTS (DOLOCKCHECKS NIL))
)
)



(* ;;; "MAKEINIT stuff")

(DEFINEQ

(ADDPME
  [LAMBDA (VP NEWPAGEOK)                                 (* bvm%: " 6-Dec-84 14:07")

    (* ;; "add an entry for VP to the PAGEMAP.  Called only under MAKEINIT")

    (PROG (PX PMP LOCKBASE)
          [COND
             ((IEQ (SETQ PMP (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)))
                   \EmptyPMTEntry)                           (* ; 
                                      "empty entries in the PageMapTBL have 177777q as their value")
              (COND
                 ((EVENP NEXTPM WORDSPERPAGE)                (* ; "must add a new page map page")
                  (SETQ PX (\ADDBASE \PAGEMAP NEXTPM))
                  (OR NEWPAGEOK (IGREATERP (PAGELOC PX)
                                       VP)
                      (HELP "page map needs new page after page map written out"))
                  (\NEWPAGE PX NIL T)))
              (\PUTBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)
                     (SETQ PMP NEXTPM))
              (SETQ NEXTPM (IPLUS NEXTPM \PMblockSize]
          (SETQ PX (IPLUS PMP (fetch (VP SECONDARYKEY) of VP)))
          (COND
             ((NEQ (\GETBASE \PAGEMAP PX)
                   0)
              (HELP "page already in pagemap" VP))
             (T (\PUTBASE \PAGEMAP PX NEXTVMEM)
                [COND
                   ((LOCKEDPAGEP VP)                         (* ; 
                                                           "Set lock bit in locked page table")
                    (\PUTBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP))
                           0
                           (LOGOR (.LOCKEDVPMASK. VP)
                                  (\GETBASE LOCKBASE 0]
                (SETQ NEXTVMEM (ADD1 NEXTVMEM])

(CHECKIFPAGE
  [LAMBDA NIL                                            (* mjs "19-Jul-84 13:24")
    (CHECKIF Key EQUAL \IFPValidKey "Interface page key"])

(DUMPINITPAGES
  [LAMBDA (CODEFIRSTPAGE CODENEXTPAGE VERSIONS)          (* bvm%: "14-Jan-85 12:51")
                                                             (* ; "called only under MAKEINIT")
    (ADDPME (PAGELOC \InterfacePage)
           T)                                                (* ; 
                                                        "THE INTERFACE PAGE MUST BE THE FIRST PAGE")
    (for I from CODEFIRSTPAGE to (SUB1 CODENEXTPAGE) do 
                                                             (* ; 
                    "add the pagemap entries for the pages which were written directly to the file")
                                                                       (ADDPME I T))
    (MAPPAGES 0 (ADD1 \MAXVMPAGE)
           (FUNCTION MAKEROOMFORPME))
    (MAPPAGES 0 (ADD1 \MAXVMPAGE)
           (FUNCTION ADDPME))
    (PROGN                                                   (* ; 
                     "set interface page locations --- stack pointers already set up IN SETUPSTACK")
           (replace (IFPAGE NxtPMAddr) of \InterfacePage with NEXTPM)
           (replace (IFPAGE NActivePages) of \InterfacePage with (SUB1 NEXTVMEM))
           (replace (IFPAGE NDirtyPages) of \InterfacePage with (SUB1 NEXTVMEM))
           (replace (IFPAGE filePnPMP0) of \InterfacePage with (\GETBASE \PAGEMAP 0))
           (replace (IFPAGE filePnPMT0) of \InterfacePage with (\GETBASE
                                                                            (.PAGEMAPBASE.
                                                                             (PAGELOC \PageMapTBL))
                                                                            0))
           [COND
              (VERSIONS (replace (IFPAGE LVersion) of \InterfacePage with (CAR VERSIONS))
                     (replace (IFPAGE MinBVersion) of \InterfacePage with (CADDR VERSIONS
                                                                                             ))
                     (replace (IFPAGE MinRVersion) of \InterfacePage with (CADR VERSIONS]
           (replace (IFPAGE Key) of \InterfacePage with \IFPValidKey))
    (MAPPAGES 0 (ADD1 \MAXVMPAGE)
           (FUNCTION DUMPVP))
    (ALLOCAL (PROG ((FILE (OUTPUT)))
                   [COND
                      ((NOT (RANDACCESSP FILE))              (* ; 
                                "SYSOUT file is sequential;  have to get it random access for this")
                       (OUTPUT (SETQ FILE (OPENFILE (CLOSEF FILE)
                                                 'BOTH]
                   (SETFILEPTR FILE MKI.Page0Byte)))
    (DUMPVP (PAGELOC \InterfacePage])

(MAKEROOMFORPME
  [LAMBDA (VP)                                           (* bvm%: "29-MAR-83 17:11")

    (* ;; 
 "make sure that the pagemap-page for page VP exists;  we later will want to add it to the pagemap")

    (COND
       ((IEQ (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP))
             \EmptyPMTEntry)                                 (* ; 
                                      "empty entries in the PageMapTBL have 177777q as their value")
        (COND
           ((EVENP NEXTPM WORDSPERPAGE)                      (* ; "must add a new page map page")
            (\NEWPAGE (\ADDBASE \PAGEMAP NEXTPM)
                   NIL T)))
        (\PUTBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)
               NEXTPM)
        (SETQ NEXTPM (IPLUS NEXTPM \PMblockSize])

(MAPPAGES
  [LAMBDA (BOT TOP FN)                        (* ; 
                                                "Edited  5-Nov-92 15:41 by sybalsky:mv:envos")

    (* ;; "Map thru all pages from BOT to TOP that exist, skipping the interface page, if it falls into that range.  Call FN on the page number.")

    (PROG ((VP BOT)
           (IVP (PAGELOC \InterfacePage)))
      LP  (COND
             ((AND (SETQ VP (MKI.NEXTPAGE VP))
                   (IGREATERP TOP VP))
              (COND
                 ((NOT (IEQ VP IVP))
                  (APPLY* FN VP)))
              (SETQ VP (ADD1 VP))
              (GO LP])

(READPAGEMAP
  [LAMBDA NIL                                            (* bvm%: "10-Dec-84 21:54")
                                                             (* ; 
                          "called only under READSYS -- reads in pagemap so that SETVMPTR can work")
    (PROG (D)
          (LOCAL (MAPVMPAGE (fetch (POINTER PAGE#) of \InterfacePage)
                        1))                                  (* ; "Install interface page by magic")
                                                             (* PROGN (SETQ FPSTART
                                                           (fetch (IFPAGE LastDominoFilePage) 
                                                           of \InterfacePage))
                                                           (SETQ NPAGES (fetch
                                                           (IFPAGE NActivePages) of 
                                                           \InterfacePage)) (* ;
                                                           "Note: have to do these fetches before the SETFILEPTR since they indirectly do SETFILEPTR themselves")
                                                           (SETFILEPTR VMEMFILE
                                                           (IPLUS (UNFOLD (SUB1
                                                           (fetch (IFPAGE FPTOVPStart) of 
                                                           \InterfacePage)) BYTESPERPAGE)
                                                           (UNFOLD FPSTART BYTESPERWORD)))
                                                           (for I from FPSTART to NPAGES bind 
                                                           VP when (NEQ (SETQ VP
                                                           (VBIN2)) \NO.VMEM.PAGE) do
                                                           (* ; "Read in all of FPTOVP")
                                                           (MAPVMPAGE VP (SUB1 I))))
          [LOCAL (MAPVMPAGE (PAGELOC \PAGEMAP)
                        (SUB1 (fetch (IFPAGE filePnPMP0) of \InterfacePage]
                                                             (* ; "map in first page of secondary page map, which is where all the secondary map pages themselves live")
          (LOCAL (SETVMPTR \PAGEMAP))
          (for I from 0 to (SUB1 (FOLDHI PAGESPERSEGMENT \PMblockSize)) as VP
             from (PAGELOC \PAGEMAP) by \PMblockSize do 
                                                             (* ; 
"Have to read all the addresses of secondary map pages themselves before we can read their contents")
                                                                   (READPAGEMAPBLOCK VP))
          (for J from 0 to (SUB1 \NumPMTpages) as FP
             from (SUB1 (fetch (IFPAGE filePnPMT0) of \InterfacePage))
             do                                          (* ; 
                                                          "read in all the primary map table pages")
                   (LOCAL (MAPVMPAGE (IPLUS (PAGELOC \PageMapTBL)
                                            J)
                                 FP)))
          (for I from 0 to (SUB1 (UNFOLD \NumPMTpages WORDSPERPAGE))
             do (COND
                       ((IEQ (SETQ D (GETBASE \PageMapTBL I))
                             \EmptyPMTEntry))
                       (T (LOCAL (SETVMPTR (ADDBASE \PAGEMAP D)))
                          (READPAGEMAPBLOCK (UNFOLD I \PMblockSize])

(READPAGEMAPBLOCK
  [LAMBDA (VP)                                           (* lmm " 4-MAY-82 21:12")
    (PROG ((B VP)
           P)
          (FRPTQ \PMblockSize [COND
                                 ((NEQ (SETQ P (VBIN2))
                                       0)
                                  (LOCAL (MAPVMPAGE B (SUB1 P]
                 (SETQ B (ADD1 B])

(SETUPPAGEMAP
  [LAMBDA NIL                                 (* ; 
                                                "Edited  5-Nov-92 16:03 by sybalsky:mv:envos")
                                                             (* ; 
                                             "called only from MAKEINIT to initialize the page map")
    (PROG NIL                                                (* ; "set up page map")
          (\NEWPAGE \PAGEMAP NIL T)                      (* ; 
                                                           "Create 1 page worth of real page table")
          (CREATEPAGES \PageMapTBL \NumPMTpages NIL T)       (* ; "And the segment table.")

     (* ;; "init PageMapTBL pages to 177777q:")

          (for I from 0 to (SUB1 (UNFOLD \NumPMTpages WORDSPERPAGE))
             do (\PUTBASE \PageMapTBL I \EmptyPMTEntry))
          (SETQ NEXTPM 0)
          (for I from 0 to (SUB1 (fetch (VP PRIMARYKEY) of \NumPageMapPages))
             bind (PAGEMAPKEY _ (fetch (VP PRIMARYKEY) of (PAGELOC \PAGEMAP)))
             do 

                   (* ;; "Assign pagemap pages to cover all pagemap pages, so that \DONEWPAGE can guarantee that when it needs to allocate a new pagemap page, that the pagemap page for the new page already exists")

                   (\PUTBASE \PageMapTBL (IPLUS PAGEMAPKEY I)
                          NEXTPM)
                   (SETQ NEXTPM (IPLUS NEXTPM \PMblockSize)))
          (SETQ NEXTVMEM \FirstVmemBlock)                    (* ; 
                                      "add entry for InterfacePage which must be on FirstVMemBlock")
          (CREATEPAGES \LOCKEDPAGETABLE \NumLPTPages NIL T])
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS CHECKIF MACRO [(FLD COMPARISON VALUE STR)
                                 (COND
                                    ((NOT (COMPARISON VALUE (fetch (IFPAGE FLD) of 
                                                                                       \InterfacePage
                                                                   )))
                                     (printout T "Warning: " STR "= " (PROGN VALUE)
                                            ", but \InterfacePage says "
                                            (fetch (IFPAGE FLD) of \InterfacePage)
                                            T])
)


(ADDTOVAR INEWCOMS (FNS DUMPINITPAGES)
                       (VARS INITCONSTANTS)
                       (FNS SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES))

(ADDTOVAR RDCOMS (FNS READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE \LOCKEDPAGEP \LOOKUPPAGEMAP 
                          CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \SHOWPAGETABLE \PRINTFPTOVP))

(ADDTOVAR EXPANDMACROFNS CHECKIF .LOCKEDVPBASE. .LOCKEDVPMASK. .PAGEMAPBASE.)

(ADDTOVAR MKI.SUBFNS (\NEWPAGE . MKI.NEWPAGE)
                         (\LOCKPAGES . MKI.LOCKPAGES))

(ADDTOVAR RD.SUBFNS (\NEWPAGE . VNEWPAGE)
                        (\LOCKPAGES . VLOCKPAGES))

(ADDTOVAR RDPTRS (\REALPAGETABLE))

(ADDTOVAR RDVALS (\RPTSIZE))
EVAL@COMPILE 

(ADDTOVAR DONTCOMPILEFNS DUMPINITPAGES SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES READPAGEMAP 
                                   READPAGEMAPBLOCK CHECKIFPAGE)
)
(DEFINEQ

(\LOCKFN
  [LAMBDA (FN)                                           (* bvm%: "22-NOV-82 17:39")
    [\LOCKCELL (SETQ FN (fetch (LITATOM DEFINITIONCELL) of (EVQ FN]
    (COND
       ((fetch (DEFINITIONCELL CCODEP) of FN)
        (\LOCKCODE (fetch (DEFINITIONCELL DEFPOINTER) of FN])

(\LOCKCODE
  [LAMBDA (CODEBLOCK)                                    (* rmk%: "15-Aug-84 13:35")
    (\LOCKWORDS CODEBLOCK (UNFOLD (\#BLOCKDATACELLS CODEBLOCK)
                                     WORDSPERCELL])

(\LOCKVAR
  [LAMBDA (VAR)                                          (* lmm " 5-APR-82 00:43")
    (\LOCKCELL (fetch (LITATOM VCELL) of (EVQ VAR])

(\LOCKCELL
  [LAMBDA (X NPGS)                                       (* bvm%: "22-NOV-82 17:54")
    (\LOCKPAGES (PAGEBASE X)
           (OR NPGS 1])

(\LOCKWORDS
  [LAMBDA (BASE NWORDS)                                  (* bvm%: "22-NOV-82 17:35")
    (\LOCKPAGES (PAGEBASE BASE)
           (COND
              (NWORDS (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BASE)
                                     NWORDS)
                             WORDSPERPAGE))
              (T 1])
)
(DECLARE%: DONTCOPY 

(ADDTOVAR INEWCOMS
          (FNS \LOCKFN \LOCKVAR \LOCKCELL \LOCKWORDS \LOCKCODE)
          (ALLOCAL (ADDVARS (LOCKEDFNS \FAULTHANDLER \FAULTINIT \DOVE.FAULTINIT \D01.FAULTINIT 
                                   \DL.FAULTINIT \CHAIN.UP.RPT \MAKESPACEFORLOCKEDPAGE \PAGEFAULT 
                                   \WRITEMAP \LOOKUPPAGEMAP \LOCKEDPAGEP \LOADVMEMPAGE \MOVEREALPAGE
                                   \INVALIDADDR \INVALIDVP \SELECTREALPAGE \TRANSFERPAGE \SPECIALRP 
                                   \UPDATECHAIN \MARKPAGEVACANT \FLUSHPAGE \CLEARWORDS \FLUSHVM 
                                   \DONEWPAGE \ASSURE.FPTOVP.PAGE \DONEWEPHEMERALPAGE 
                                   \WRITEDIRTYPAGE1 \COPYSYS0 \COPYSYS0SUBR \RELEASEWORKINGSET 
                                   \DOFLUSHVM \DOLOCKPAGES \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES 
                                   \MP.ERROR RAID \DL.NEWFAULTINIT \DL.MARK.PAGES.UNAVAILABLE 
                                   \DL.UNMAPPAGES \DL.ASSIGNBUFFERS \D01.ASSIGNBUFFERS 
                                   \DOCOMPRESSVMEM \MOVEVMEMFILEPAGE \SET.VMEM.FULL.STATE \HINUM 
                                   \LONUM \ATOMCELL SETTOPVAL)
                          (LOCKEDVARS \REALPAGETABLE \RPTLAST \PAGEFAULTCOUNTER \UPDATECHAINFREQ 
                                 \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP 
                                 \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK 
                                 \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE 
                                 \VMEM.PURE.LIMIT \VMEM.FULL.STATE \GUARDVMEMFULL VMEM.COMPRESS.FLG 
                                 \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP \MACHINETYPE 
                                 \VMEMACCESSFN \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND 
                                 \MAXSWAPBUFFERS \EMUBUFFERS \#EMUBUFFERS \#SWAPBUFFERS \#DISKBUFFERS
                                 \RCLKSECOND \RCLKMILLISECOND \VALSPACE \EMUSWAPBUFFERS 
                                 \EM.CURSORBITMAP \PAGEMAP \PageMapTBL \IOCBPAGE \IOPAGE \MISCSTATS 
                                 \DEFSPACE \InterfacePage \LASTVMEMFILEPAGE \DoveIORegion 
                                 \MaxScreenPage \NEWVMEMPAGEADDED))))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA VMEM.PURE.STATE)
)
(PUTPROPS LLFAULT COPYRIGHT ("Venue & Xerox Corporation" 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 
3705Q 3706Q 3707Q 3710Q 3711Q 3745Q))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (33017Q 67143Q (\FAULTINIT 33031Q . 42260Q) (\D01.FAULTINIT 42262Q . 47707Q) (
\D01.ASSIGNBUFFERS 47711Q . 53456Q) (\MAIKO.FAULTINIT 53460Q . 56245Q) (\MAIKO.NEWFAULTINIT 56247Q . 
57603Q) (\MAIKO.ASSIGNBUFFERS 57605Q . 63361Q) (\M-VMEMSAVE 63363Q . 66603Q) (\MAIKO.NEWPAGE 66605Q . 
67141Q)) (67343Q 74771Q (\MAIKO.DO.MOVDS 67355Q . 74767Q)) (76130Q 166610Q (\DOVE.FAULTINIT 76142Q . 
102535Q) (\DL.FAULTINIT 102537Q . 107630Q) (\DL.NEWFAULTINIT 107632Q . 154344Q) (\DL.UNMAPPAGES 
154346Q . 155334Q) (\DL.MARK.PAGES.UNAVAILABLE 155336Q . 156274Q) (\DL.ASSIGNBUFFERS 156276Q . 162017Q
) (\CHAIN.UP.RPT 162021Q . 166606Q)) (166653Q 253066Q (\FAULTHANDLER 166665Q . 167543Q) (\PAGEFAULT 
167545Q . 173304Q) (\INVALIDADDR 173306Q . 173562Q) (\INVALIDVP 173564Q . 174023Q) (\FLUSHPAGE 174025Q
 . 201166Q) (\LOADVMEMPAGE 201170Q . 205242Q) (\MOVEREALPAGE 205244Q . 210504Q) (\LOOKUPPAGEMAP 
210506Q . 211500Q) (\VALIDADDRESSP 211502Q . 211772Q) (\LOCKEDPAGEP 211774Q . 213176Q) (
\SELECTREALPAGE 213200Q . 235135Q) (\SPECIALRP 235137Q . 236154Q) (\TRANSFERPAGE 236156Q . 244017Q) (
\UPDATECHAIN 244021Q . 253064Q)) (253150Q 327741Q (\NEWPAGE 253162Q . 255200Q) (\DONEWPAGE 255202Q . 
264741Q) (\ASSURE.FPTOVP.PAGE 264743Q . 267715Q) (\MAKESPACEFORLOCKEDPAGE 267717Q . 275321Q) (
\MOVEVMEMFILEPAGE 275323Q . 277744Q) (\NEWEPHEMERALPAGE 277746Q . 300477Q) (\DONEWEPHEMERALPAGE 
300501Q . 305717Q) (\LOCKPAGES 305721Q . 306345Q) (\DOLOCKPAGES 306347Q . 316113Q) (\TEMPLOCKPAGES 
316115Q . 316624Q) (\DOTEMPLOCKPAGES 316626Q . 321641Q) (\TEMPUNLOCKPAGES 321643Q . 324525Q) (
\UNLOCKPAGES 324527Q . 327737Q)) (330007Q 357025Q (\FLUSHVM 330021Q . 332261Q) (\LOGOUT0 332263Q . 
334236Q) (\DOFLUSHVM 334240Q . 336724Q) (\RELEASEWORKINGSET 336726Q . 340516Q) (\WRITEDIRTYPAGE 
340520Q . 354264Q) (\WRITEDIRTYPAGE1 354266Q . 355613Q) (\COUNTREALPAGES 355615Q . 357023Q)) (357073Q 
362422Q (\DOCOMPRESSVMEM 357105Q . 361423Q) (VMEM.PURE.STATE 361425Q . 362420Q)) (362671Q 373200Q (
32MBADDRESSABLE 362703Q . 363351Q) (\SET.VMEM.FULL.STATE 363353Q . 365274Q) (\SET.LASTVMEMFILEPAGE 
365276Q . 366647Q) (\DOVMEMFULLINTERRUPT 366651Q . 372414Q) (\FLUSHVMOK? 372416Q . 373176Q)) (374654Q 
375310Q (\MP.ERROR 374666Q . 375306Q)) (375441Q 425251Q (\ACTONVMEMFILE 375453Q . 376252Q) (
\SHOWPAGETABLE 376254Q . 403755Q) (CHECKPAGEMAP 403757Q . 411641Q) (CHECKFPTOVP 411643Q . 412655Q) (
CHECKFPTOVP1 412657Q . 414046Q) (\PRINTFPTOVP 414050Q . 424733Q) (\PRINTVP 424735Q . 425247Q)) (
445216Q 474714Q (ADDPME 445230Q . 450577Q) (CHECKIFPAGE 450601Q . 451053Q) (DUMPINITPAGES 451055Q . 
456473Q) (MAKEROOMFORPME 456475Q . 460175Q) (MAPPAGES 460177Q . 461376Q) (READPAGEMAP 461400Q . 
470555Q) (READPAGEMAPBLOCK 470557Q . 471347Q) (SETUPPAGEMAP 471351Q . 474712Q)) (500023Q 502371Q (
\LOCKFN 500035Q . 500540Q) (\LOCKCODE 500542Q . 501104Q) (\LOCKVAR 501106Q . 501356Q) (\LOCKCELL 
501360Q . 501624Q) (\LOCKWORDS 501626Q . 502367Q)))))
STOP
\ No newline at end of file
diff --git a/sources/LLFAULT.LCOM b/sources/LLFAULT.LCOM
index 91a09f61..4befe3fe 100644
Binary files a/sources/LLFAULT.LCOM and b/sources/LLFAULT.LCOM differ
diff --git a/sources/LLKEY b/sources/LLKEY
index 04a57a3d..037707a5 100644
--- a/sources/LLKEY
+++ b/sources/LLKEY
@@ -1,4 +1,4 @@
-(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
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "13-Feb-2021 23:24:49" {DSK}<home>larry>ilisp>medley>sources>LLKEY.;2 206612 

      changes to%:  (FNS \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS)

      previous date%: "12-Feb-2021 19:16:08" {DSK}<home>larry>ilisp>medley>sources>LLKEY.;1)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992, 1999, 1920, 2000, 2018, 2021 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)
              (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.")

    (LET [(CAPS-LOCK-ACTIONS (COND
                                ((EQUAL (UNIX-GETPARM "DISPLAY")
                                        "X")
                                 '((56 LOCKTOGGLE . IGNORE)
                                   (72 LOCKDOWN . LOCKUP]

         (* ;; "seems like X defaults to not handling lock these days, so I changed the defaulet handling of LOCK 56 -- LMM 2/13/2021")

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

(\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])
)
(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
@@ -32,4 +32,4 @@
                                                (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
+            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 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (14777 22093 (BKSYSCHARCODE 14787 . 15136) (\CLEARSYSBUF 15138 . 15696) (\GETKEY 15698
 . 16873) (\NSYSBUFCHARS 16875 . 17617) (\SAVESYSBUF 17619 . 19228) (\SYSBUFP 19230 . 19534) (
\GETSYSBUF 19536 . 19716) (\PUTSYSBUF 19718 . 20931) (\PEEKSYSBUF 20933 . 22091)) (23351 60185 (
\KEYBOARDINIT 23361 . 25081) (\KEYBOARDEVENTFN 25083 . 29783) (\ALLOCLOCKED 29785 . 30375) (
\SETIOPOINTERS 30377 . 34913) (\KEYBOARDOFF 34915 . 35329) (\KEYBOARDON 35331 . 35710) (\KEYHANDLER 
35712 . 35843) (\KEYHANDLER1 35845 . 43291) (\RESETKEYBOARD 43293 . 44941) (\DOMOUSECHORDING 44943 . 
48763) (\DOTRANSITIONS 48765 . 49442) (\DECODETRANSITION 49444 . 56133) (MOUSECHORDWAIT 56135 . 56799)
 (\TRACKCURSOR 56801 . 60183)) (102601 124455 (KEYACTION 102611 . 103455) (KEYACTIONTABLE 103457 . 
104639) (KEYBOARDTYPE 104641 . 105743) (RESETKEYACTION 105745 . 107504) (
\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS 107506 . 109408) (\KEYACTION1 109410 . 120031) (KEYDOWNP 120033
 . 120368) (KEYNUMBERP 120370 . 120568) (\KEYNAMETONUMBER 120570 . 121264) (MODIFY.KEYACTIONS 121266
 . 122127) (METASHIFT 122129 . 123073) (SHIFTDOWNP 123075 . 124453)) (124518 124814 (
SETUP.OFFICE.KEYBOARD 124528 . 124812)) (127754 129466 (\INIT.KEYBOARD.STREAM 127764 . 129464)) (
129731 146108 (\DOBUFFEREDTRANSITIONS 129741 . 145171) (\TIMER.INTERRUPTFRAME 145173 . 145898) (
\PERIODIC.INTERRUPTFRAME 145900 . 146106)) (146362 150439 (\HARDCURSORUP 146372 . 148254) (
\HARDCURSORPOSITION 148256 . 150292) (\HARDCURSORDOWN 150294 . 150437)) (150440 174500 (CURSOR.INIT 
150450 . 154150) (\CURSORDESTINATION 154152 . 156470) (\SOFTCURSORUP 156472 . 161726) (
\SOFTCURSORUPCURRENT 161728 . 168764) (\SOFTCURSORPOSITION 168766 . 169531) (\SOFTCURSORDOWN 169533 . 
170241) (CURSORPROP 170243 . 170585) (GETCURSORPROP 170587 . 170775) (PUTCURSORPROP 170777 . 171932) (
\CURSORBITSPERPIXEL 171934 . 174050) (\CURSORIMAGEPROPNAME 174052 . 174276) (\CURSORMASKPROPNAME 
174278 . 174498)) (174501 192451 (CURSORCREATE 174511 . 177186) (CURSOR 177188 . 179000) (
\CURSOR-VALID-P 179002 . 180089) (\CURSORUP 180091 . 181806) (\CURSORPOSITION 181808 . 184336) (
\CURSORDOWN 184338 . 184571) (ADJUSTCURSORPOSITION 184573 . 185151) (CURSORPOSITION 185153 . 186695) (
CURSORSCREEN 186697 . 187353) (CURSOREXIT 187355 . 188746) (FLIPCURSOR 188748 . 189874) (FLIPCURSORBAR
 189876 . 190856) (LASTMOUSEX 190858 . 191112) (LASTMOUSEY 191114 . 191368) (CREATEPOSITION 191370 . 
191576) (POSITIONP 191578 . 191862) (CURSORHOTSPOT 191864 . 192449)) (193685 195233 (GETMOUSESTATE 
193695 . 194354) (\EVENTKEYS 194356 . 195231)) (201094 201890 (MACHINETYPE 201104 . 201504) (
SETMAINTPANEL 201506 . 201888)) (201920 203059 (BEEPON 201930 . 202583) (BEEPOFF 202585 . 203057)) (
203510 203773 (WITHOUT-INTERRUPTS 203520 . 203771)))))
STOP
\ No newline at end of file
diff --git a/sources/LLKEY.LCOM b/sources/LLKEY.LCOM
index b2317868..4a7efdcf 100644
Binary files a/sources/LLKEY.LCOM and b/sources/LLKEY.LCOM differ
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/LLPARAMS b/sources/LLPARAMS
index 3326f475..7e470a62 100644
--- a/sources/LLPARAMS
+++ b/sources/LLPARAMS
@@ -1,1705 +1 @@
-(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 37776Q)
-                          (\MaxMDSPage 1777775Q)
-                          (\DefaultSecondMDSPage 177774Q)
-                          (\MDSIncrement 1000Q)
-                          (\PagesPerMDSUnit 2)
-                                                             (* ; 
-                                                           "(FOLDLO \MDSIncrement WORDSPERPAGE)")
-                          
-                          (* ;; "arrays")
-
-                          (\ARRAYSPACE (56Q 0))
-                          (\FirstArraySegment 56Q)
-                          (\FirstArrayPage 27000Q)
-                          (\ARRAYSPACE2 (100Q 0))
-                          (\DefaultSecondArrayPage 40000Q)
-                          
-                          (* ;; "stack block constants")
-
-                          (\StackMask 160000Q T T)
-                          (\FxtnBlock 140000Q T T)
-                          (\GuardBlock 160000Q T T)
-                          (\BFBlock 100000Q T T)
-                          (\FreeStackBlock 120000Q T T)
-                          (\NotStackBlock 0)
-                                                             (* ; "none of the above")
-                          (\MinExtraStackWords 40Q T T)
-                          
-                          (* ;; "backspace kludge")
-
-                          (ERASECHARCODE 0 T)
-                          
-                          (* ;; "GC constants")
-
-                          (\HT1CNT 2000Q NIL T)
-                          (\HTSTKBIT 1000Q NIL T)
-                          (\HTCNTMASK 176000Q NIL T)
-                          (\HTMAINSIZE 200000Q NIL T)
-                          (\HTCOLLSIZE 4000000Q NIL T)
-                                                             (* ; "HTCOLL size in words")
-                          (\HTENDFREE 1 NIL T)
-                          (\HTFREEPTR 0 NIL T)
-                          
-                          (* ;; "pointers and lengths of various data spaces")
-
-                          (\ATOMSPACE (0 0)
-                                 (ATOMspace NIL)
-                                 (atomHiVal NIL))
-                          (\AtomHI 0)
-                          (\CHARHI 7)
-                                                             (* ; 
-                                            "overlap character space and the atom hash table space")
-                          (\AtomHashTable (25Q 0)
-                                 (AHTspace AHTbase))
-                          (\AtomHTpages 400Q AHTSIZE)
-                          (\LastAtomPage 377Q)
-                          (\MaxAtomFrLst 177777Q)
-                          (\SMALLPOSPSPACE (16Q 0))
-                          (\SmallPosHi 16Q SMALLPOSspace smallpl)
-                          (\SMALLNEGSPACE (17Q 0))
-                          (\SmallNegHi 17Q SMALLNEGspace smallneg)
-                          (\NumSmallPages 1000Q)
-                          
-                          (* ;; "PNAME SPACEin the old world; used for initial atoms now.")
-
-                          (\PNPSPACE (10Q 0)
-                                 (PNPspace PNPbase))
-                          (\PNAME.HI 10Q)
-                          (\OLDATOMSPACE (54Q 0))
-                                                             (* ; "NEW ATOM SPACE")
-                          (\ATOM.HI 54Q)
-                                                             (* ; "HI PART OF NEW ATOM SPACE")
-                          
-                          (* ;; "Definitions in old atom world")
-
-                          (\DEFSPACE (12Q 0)
-                                 (DEFspace DEFbase)
-                                 (DEFspace DEFbase))
-                          (\DEF.HI 12Q)
-                          (\VALSPACE (14Q 0)
-                                 (TOPVALspace TOPVALbase)
-                                 (VALspace VALbase))
-                          (\VAL.HI 14Q)
-                          (\PLISTSPACE (2 0)
-                                 (PLISTspace PLISTbase))
-                          (\PLIST.HI 2)
-                          (\PAGEMAP (5 0)
-                                 (PAGEMAPspace PAGEMAPbase))
-                          (\NumPageMapPages 400Q)
-                          (\PageMapTBL (24Q 1000Q)
-                                 (PMTspace PMTbase))
-                          (\InterfacePage (24Q 0)
-                                 (INTERFACEspace INTERFACEbase)
-                                 (INTERFACEspace INTERFACEbase))
-                          (\IOPAGE (0 177400Q))
-                          (\DoveIORegion (0 40000Q))
-                          (\IOCBPAGE (0 400Q))
-                          (\FPTOVP (2 0))
-                          (\MDSTypeTable (30Q 0)
-                                 (MDSTYPEspace MDSTYPEbase)
-                                 (MDSTYPEspace MDSTYPEbase))
-                          (\MDSTTsize 2000Q T)
-                                                             (* ; "in Pages")
-                          (\MISCSTATS (24Q 5000Q)
-                                 (STATSspace MISCSTATSbase))
-                          (\UFNTable (24Q 6000Q)
-                                 NIL
-                                 (STATSspace UFNTablebase))
-                          (\UFNTableSize 2)
-                          (\DTDSpaceBase (24Q 10000Q)
-                                 (DTDspace DTDbase)
-                                 (DTDspace DTDbase))
-                          (\DTDSize 22Q T)
-                          (\LISTPDTD (24Q 10132Q))
-                          (\EndTypeNumber 3777Q)
-                          (\LOCKEDPAGETABLE (24Q 70000Q))
-                          (\NumLPTPages 20Q)
-                          (\STACKSPACE (1 0)
-                                 (STACKspace NIL)
-                                 (STACKspace NIL))
-                          (\GuardStackAddr 170000Q)
-                          (\LastStackAddr 177776Q)
-                          (\STACKHI 1 T T)
-                          (\HTMAIN (26Q 0)
-                                 (HTMAINspace HTMAINbase)
-                                 (HTMAINspace HTMAINbase))
-                          (\HTMAINnpages 400Q T)
-                          (\HTOVERFLOW (27Q 0)
-                                 NIL
-                                 (NIL HTOVERFLOWbase))
-                          (\HTBIGCOUNT (27Q 100000Q))
-                          (\HTCOLL (34Q 0)
-                                 NIL
-                                 (HTCOLLspace HTCOLLbase))
-                          (\DISPLAYREGION (22Q 0))
-                          (\D1BCPLspace 0 T LEmubrHiVal)
-                          (\D0BCPLspace 0 T)
-                          
-                          (* ;; "Interface Page locations")
-
-                          (\CurrentFXP 0 T T)
-                          (\ResetFXP 1 T T)
-                          (\SubovFXP 2 T T)
-                          (\KbdFXP 3 T T)
-                          (\HardReturnFXP 4 T T)
-                          (\GCFXP 5)
-                          (\FAULTFXP 6 T T)
-                          (\MiscFXP 16Q T T)
-                          (\TeleRaidFXP 30Q T T)
-                          
-                          (* ;; "emulator segment locations")
-
-                          (DCB.EM 420Q)
-                          (DISPINTERRUPT.EM 421Q)
-                          (CURSORBITMAP.EM 431Q)
-                          (KBDAD0.EM 177034Q)
-                          (KBDAD1.EM 177035Q)
-                          (KBDAD2.EM 177036Q)
-                          (KBDAD3.EM 177037Q)
-                          (UTILIN.EM 177030Q)
-                          (CURSORX.EM 426Q)
-                          (CURSORY.EM 427Q)
-                          (MOUSEX.EM 424Q)
-                          (MOUSEY.EM 425Q)
-                          (\LispKeyMask 20000Q T T)
-                          (\BcplKeyMask 10400Q T T)
-                                                             (* ; "Machine types")
-                          (\MAIKO 3)
-                          (\DOLPHIN 4)
-                          (\DORADO 5)
-                          (\DANDELION 6)
-                          (\DAYBREAK 10Q)
-                          
-                          (* ;; "FOR DLION (AND DAYBREAK)")
-
-                          (\VP.DISPLAY 11000Q)
-                          (\NP.DISPLAY 312Q)
-                                                             (* ; 
-                           "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)")
-                          (\NP.WIDEDOVEDISPLAY 363Q)
-                                                             (* ; 
-                                                           "Wide Dove display 1152x864 pixels")
-                          (\WIDEDOVEDISPLAYWIDTH 2200Q)
-                          (\RP.AFTERDISPLAY 316Q)
-                                                             (* ; "Includes 4 pages for cursor")
-                          (\RP.AFTERDOVEDISPLAY 363Q)
-                                                             (* ; "if big screen")
-                          (\RP.DISPLAY 0)
-                          (\RP.TEMPDISPLAY 5001Q)
-                          (\RP.MISCLOCKED 5364Q)
-                                                             (* ; 
-                                                          "(+ \RP.TEMPDISPLAY \NP.WIDEDOVEDISPLAY)")
-                          (\RP.STACK 1400Q)
-                          (\VP.STACK 400Q)
-                          (\RP.MAP 400Q)
-                          (\NP.MAP 400Q)
-                          (\RP.IOPAGE 1000Q)
-                                                             (* ; 
-                          "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range")
-                          (\RP.DOVEIOCBPAGE 1037Q)
-                          (\RP.DOVEIORGN 1040Q)
-                          (\VP.DOVEIORGN 100Q)
-                          (\DOVEIORGNSIZE 100Q)
-                          (\VP.IOPAGE 377Q)
-                          (\VP.IFPAGE 12000Q)
-                          (\VP.FPTOVP 1000Q)
-                          (\NP.FPTOVP 10000Q)
-                          (\RP.FPTOVP 2000Q)
-                          (\RP.STARTBUFFERS 1200Q)
-                          (\VP.TYPETABLE 14000Q)
-                          (\NP.TYPETABLE 2000Q)
-                          (\RP.TYPETABLE 12000Q)
-                          (\VP.GCTABLE 13000Q)
-                          (\NP.GCTABLE 400Q)
-                          (\RP.GCTABLE 14000Q)
-                          (\VP.GCOVERFLOW 13400Q)
-                          (\NP.GCOVERFLOW 1)
-                          (\RP.GCOVERFLOW 14400Q)
-                          (\FP.IFPAGE 2)
-                          (\VP.IOCBS 1)
-                          (\VP.PRIMARYMAP 12002Q)
-                          (\VP.SECONDARYMAP 2400Q)
-                          (\VP.LPT 12160Q)
-                          (\VP.INITSCRATCH 10Q)
-                          (\VP.RPT 200Q)
-                          (\VP.BUFFERS 332Q)
-                                                             (* ; "DLion processor commands")
-                          (\DL.PROCESSORBUSY 100000Q)
-                          (\DL.SETTOD 100001Q)
-                          (\DL.READTOD 100002Q)
-                          (\DL.READPID 100003Q)
-                          (\DL.BOOTBUTTON 100004Q)))
-
-(RPAQQ MISCSTATSLAYOUT ((STARTTIME FIXP MSstrtTime)
-                            (TOTALTIME FIXP)
-                            (SWAPWAITTIME FIXP T)
-                            (PAGEFAULTS FIXP T)
-                            (SWAPWRITES FIXP T)
-                            (DISKIOTIME FIXP T)
-                            (DISKOPS FIXP T)
-                            (KEYBOARDWAITTIME FIXP T)
-                            (GCTIME FIXP T)
-                            (NETIOTIME FIXP T)
-                            (NETIOOPS FIXP T)
-                            (SWAPTEMP0 FIXP)
-                            (SWAPTEMP1 FIXP)
-                            (RCLKSECOND FIXP)
-                            (SECONDSCLOCK FIXP)
-                            (MILLISECONDSCLOCK FIXP)
-                            (BASECLOCK FIXP)
-                            (RCLKTEMP0 FIXP)
-                            (SECONDSTMP FIXP)
-                            (MILLISECONDSTMP FIXP)
-                            (BASETMP FIXP)
-                            (EXCESSTIMETMP FIXP)
-                            (CLOCKTEMP0 FIXP)
-                            (DISKTEMP0 FIXP)
-                            (DISKTEMP1 FIXP)
-                            (TELERAIDTEMP1 FIXP)
-                            (TELERAIDTEMP2 FIXP)
-                            (TELERAIDTEMP3 FIXP)
-                            (LASTUSERACTION FIXP)
-                            (DLMOUSETIMER FIXP)
-                            (DLMOUSETEMP FIXP)))
-
-(RPAQQ IFPAGELAYOUT ((CurrentFXP WORD)
-                                                             (* ; 
-                                      "First 7 items are FX values for user and 6 system contexts.")
-                         (ResetFXP WORD)
-                         (SubovFXP WORD)
-                         (KbdFXP WORD)
-                         (HardReturnFXP WORD)
-                         (GCFXP WORD)
-                         (FAULTFXP WORD)
-                         (EndOfStack WORD)
-                                                             (* ; 
-                            "Stack high-water mark: address of guard block at current end of stack")
-                         (LVersion WORD)
-                                                             (* ; 
-           "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp")
-                         (MinRVersion WORD)
-                         (MinBVersion WORD)
-                         (RVersion WORD)
-                                                             (* ; 
-                                               "Bcpl fills in the actual microcode, Bcpl versions.")
-                         (BVersion WORD)
-                         (MachineType WORD)
-                         (MiscFXP WORD)
-                                                             (* ; "FX for MISC context")
-                         (Key WORD)
-                                                             (* ; 
-                                                           "= IFPValidKey if vmem consistent.")
-                         (SerialNumber WORD)
-                                                             (* ; 
-                                                           "Pup host number (Dorado/Dolphin)")
-                         (EmulatorSpace WORD)
-                                                             (* ; 
-                                                           "Hiloc of bcpl space (always zero now)")
-                         (ScreenWidth WORD)
-                         (NxtPMAddr WORD)
-                                                             (* ; 
-                                            "Next page to be allocated in secondary page map table")
-                         (NActivePages WORD)
-                                                             (* ; "Length of vmem in use")
-                         (NDirtyPages WORD)
-                                                             (* ; 
-                                                       "not used, but maintained as = NActivePages")
-                         (filePnPMP0 WORD)
-                                                             (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live")
-                         (filePnPMT0 WORD)
-                                                             (* ; 
-                                       "Sysout page number of first page of primary page map table")
-                         (TELERAIDFXP WORD)
-                                                             (* ; "FX for TeleRaid server context")
-                         (NATIVE-START-MEM-PAGE WORD)
-                                                             (* ; 
-                                                           "Unix page where native code starts")
-                         (NATIVE-LENGTH-PAGE WORD)
-                                                             (* ; "Unix page length of native code")
-                         (NATIVE-PAGE-OFFSET WORD)
-                                                             (* ; 
-                                                           "Lisp Disk Page offset  of native code")
-                         (UserNameAddr WORD)
-                                                             (* ; 
-                                 "Addresses in bcpl space (seg 0) of global user name and password")
-                         (UserPswdAddr WORD)
-                         (StackBase WORD)
-                                                             (* ; 
-                                                           "Stack address where user stack starts")
-                         (FAULTHI WORD)
-                                                             (* ; 
-         "Microcode for page fault stores fault address here, then does context switch to FAULTFXP")
-                         (FAULTLO WORD)
-                         (DEVCONFIG WORD)
-                                                             (* ; "IT'S FOR KB,DISP TYPE")
-                                                             (* ; 
-                                   "Formerly REALPAGETABLE, back when it was always in Bcpl space.")
-                         (RPTSIZE WORD)
-                                                             (* ; 
-                                                           "Number of entries in Real Page Table")
-                         (RPOFFSET WORD)
-                                                             (* ; "RP-RPOFFSET => index in table")
-                         (MAXETHERBYTES WORD)
-                                                             (* ; 
-                          "Number of bytes available in a pbi, not counting encapsulation (Dorado)")
-                         (EMBUFVP WORD)
-                                                             (* ; 
-                                                           "VP of a one-page emulator buffer")
-                         (NSHost0 WORD)
-                                                             (* ; "Machine's 48-bit NS host number.  Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in.")
-                         (NSHost1 WORD)
-                         (NSHost2 WORD)
-                         (MDSZone WORD)
-                                                             (* ; 
-                                               "Obsolete -- was used by Dolphin 10MB network code.")
-                         (MDSZoneLength WORD)
-                         (EMUBUFFERS WORD)
-                                                             (* ; 
-                                             "Buffer space in segment 0 for swapping/disk activity")
-                         (EMUBUFLENGTH WORD)
-                                                             (* ; "Number of words of said space")
-                         (LASTNUMCHARS WORD)
-                                                             (* ; "No longer used?")
-                         (SYSDISK WORD)
-                                                             (* ; 
-                                 "Address of sysDisk in Bcpl space -- disk obj for boot partition.")
-                         (ISFMAP WORD)
-                         
-                         (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!")
-
-                         (MISCSTACKFN FULLXPOINTER)
-                         (MISCSTACKARG1 FULLXPOINTER)
-                         (MISCSTACKARG2 FULLXPOINTER)
-                         (MISCSTACKRESULT FULLXPOINTER)
-                         (NRealPages WORD)
-                                                             (* ; "Number pages of real memory")
-                         (LastLockedFilePage WORD)
-                                                             (* ; 
-                         "Last page of vmem that is locked--booting has to load at least that far.")
-                         (LastDominoFilePage WORD)
-                                                             (* ; 
-                                                "Last sysout page reserved for Dandelion microcode")
-                         (FPTOVPStart WORD)
-                                                             (* ; "Sysout page where FPTOVP starts")
-                         (FAKEMOUSEBITS WORD)
-                                                             (* ; 
-                                      "Used to implement fake middle button on 2-button Dandelion.")
-                         (DL24BitAddressable WORD)
-                                                             (* ; 
-                                      "non-zero if DLion capable of addressing 32MB virtual memory")
-                         (REALPAGETABLEPTR FULLXPOINTER)
-                                                             (* ; 
-                            "Address of real page table, set up by Bcpl (but not chained together)")
-                         (DLLastVmemPage WORD)
-                                                             (* ; 
-                                           "DLion booting microcode puts length of vmem file here.")
-                         (FullSpaceUsed WORD)
-                                                             (* ; 
-                                          "Non-zero if vmem beyond initial 8MB has been allocated.")
-                         (FAKEKBDAD4 WORD)
-                         (FAKEKBDAD5 WORD)
-                         
-                         (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with.")
-
-                         (XVmemFmapBase WORD)
-                                                             (* ; 
- "Bcpl stores isf map pointer to each partition here.  First is redundant with ISFMAP field above.")
-                         (NIL WORD)
-                         (NIL WORD)
-                         (XVmemFmapHighBase WORD)
-                                                             (* ; 
-                          "Bcpl stores the highest vm page contained in this or earlier partition.")
-                         (NIL WORD)
-                         (NIL WORD)
-                         (XVmemDiskBase FULLXPOINTER)
-                                                             (* ; 
-      "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).")
-                         (NIL FULLXPOINTER)
-                         (NIL FULLXPOINTER)))
-
-(RPAQQ MAIKO.IFPAGELAYOUT ((CurrentFXP WORD)
-                                                             (* ; 
-                                      "First 7 items are FX values for user and 6 system contexts.")
-                               (ResetFXP WORD)
-                               (SubovFXP WORD)
-                               (KbdFXP WORD)
-                               (HardReturnFXP WORD)
-                               (GCFXP WORD)
-                               (FAULTFXP WORD)
-                               (EndOfStack WORD)
-                                                             (* ; 
-                            "Stack high-water mark: address of guard block at current end of stack")
-                               (LVersion WORD)
-                                                             (* ; 
-           "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp")
-                               (MinRVersion WORD)
-                               (MinBVersion WORD)
-                               (RVersion WORD)
-                                                             (* ; 
-                                               "Bcpl fills in the actual microcode, Bcpl versions.")
-                               (BVersion WORD)
-                               (MachineType WORD)
-                               (MiscFXP WORD)
-                                                             (* ; "FX for MISC context")
-                               (Key WORD)
-                                                             (* ; 
-                                                           "= IFPValidKey if vmem consistent.")
-                               (SerialNumber WORD)
-                                                             (* ; 
-                                                           "Pup host number (Dorado/Dolphin)")
-                               (EmulatorSpace WORD)
-                                                             (* ; 
-                                                           "Hiloc of bcpl space (always zero now)")
-                               (ScreenWidth WORD)
-                               (NxtPMAddr WORD)
-                                                             (* ; 
-                                            "Next page to be allocated in secondary page map table")
-                               (NIL WORD)
-                                                             (* ; 
-                                                          "WAS NActivePages, Length of vmem in use")
-                               (NIL WORD)
-                                                             (* ; 
-                                      "WAS NDirtyPages, not used, but maintained as = NActivePages")
-                               (filePnPMP0 WORD)
-                                                             (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live")
-                               (filePnPMT0 WORD)
-                                                             (* ; 
-                                       "Sysout page number of first page of primary page map table")
-                               (TELERAIDFXP WORD)
-                                                             (* ; "FX for TeleRaid server context")
-                               (NATIVE-START-MEM-PAGE WORD)
-                                                             (* ; 
-                                                           "Unix page where native code starts")
-                               (NATIVE-LENGTH-PAGE WORD)
-                                                             (* ; "Unix page length of native code")
-                               (NATIVE-PAGE-OFFSET WORD)
-                                                             (* ; 
-                                                           "Lisp Disk Page offset  of native code")
-                               (UserNameAddr WORD)
-                                                             (* ; 
-                                 "Addresses in bcpl space (seg 0) of global user name and password")
-                               (UserPswdAddr WORD)
-                               (StackBase WORD)
-                                                             (* ; 
-                                                           "Stack address where user stack starts")
-                               (FAULTHI WORD)
-                                                             (* ; 
-         "Microcode for page fault stores fault address here, then does context switch to FAULTFXP")
-                               (FAULTLO WORD)
-                               (DEVCONFIG WORD)
-                                                             (* ; "IT'S FOR KB,DISP TYPE")
-                                                             (* ; 
-                                   "Formerly REALPAGETABLE, back when it was always in Bcpl space.")
-                               (RPTSIZE WORD)
-                                                             (* ; 
-                                                           "Number of entries in Real Page Table")
-                               (RPOFFSET WORD)
-                                                             (* ; "RP-RPOFFSET => index in table")
-                               (MAXETHERBYTES WORD)
-                                                             (* ; 
-                          "Number of bytes available in a pbi, not counting encapsulation (Dorado)")
-                               (EMBUFVP WORD)
-                                                             (* ; 
-                                                           "VP of a one-page emulator buffer")
-                               (NSHost0 WORD)
-                                                             (* ; "Machine's 48-bit NS host number.  Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in.")
-                               (NSHost1 WORD)
-                               (NSHost2 WORD)
-                               (MDSZone WORD)
-                                                             (* ; 
-                                               "Obsolete -- was used by Dolphin 10MB network code.")
-                               (MDSZoneLength WORD)
-                               (EMUBUFFERS WORD)
-                                                             (* ; 
-                                             "Buffer space in segment 0 for swapping/disk activity")
-                               (EMUBUFLENGTH WORD)
-                                                             (* ; "Number of words of said space")
-                               
-                               (* ;; 
-                             "The following 2 are available if NEW_STOARGE is specified in C")
-
-                               (ProcessSize WORD)
-                                                             (* ; 
-                                                  "Process size for which can be use as LISP space")
-                               (StorageFullState WORD)
-                                                             (* ; "Save last storage state")
-                               (ISFMAP WORD)
-                               
-                               (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!")
-
-                               (MISCSTACKFN FULLXPOINTER)
-                               (MISCSTACKARG1 FULLXPOINTER)
-                               (MISCSTACKARG2 FULLXPOINTER)
-                               (MISCSTACKRESULT FULLXPOINTER)
-                               (NRealPages WORD)
-                                                             (* ; "Number pages of real memory")
-                               (LastLockedFilePage WORD)
-                                                             (* ; 
-                         "Last page of vmem that is locked--booting has to load at least that far.")
-                               (LastDominoFilePage WORD)
-                                                             (* ; 
-                                                "Last sysout page reserved for Dandelion microcode")
-                               (FPTOVPStart WORD)
-                                                             (* ; "Sysout page where FPTOVP starts")
-                               (FAKEMOUSEBITS WORD)
-                                                             (* ; 
-                                      "Used to implement fake middle button on 2-button Dandelion.")
-                               (DL24BitAddressable WORD)
-                                                             (* ; 
-                                      "non-zero if DLion capable of addressing 32MB virtual memory")
-                               (REALPAGETABLEPTR FULLXPOINTER)
-                                                             (* ; 
-                            "Address of real page table, set up by Bcpl (but not chained together)")
-                               (SYSDISK WORD)
-                                                             (* ; 
-                       "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.")
-                               (FullSpaceUsed WORD)
-                                                             (* ; 
-                                          "Non-zero if vmem beyond initial 8MB has been allocated.")
-                               (FAKEKBDAD4 WORD)
-                               (FAKEKBDAD5 WORD)
-                               
-                               (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with.")
-
-                               (XVmemFmapBase WORD)
-                                                             (* ; 
- "Bcpl stores isf map pointer to each partition here.  First is redundant with ISFMAP field above.")
-                               (NIL WORD)
-                               (NIL WORD)
-                               (XVmemFmapHighBase WORD)
-                                                             (* ; 
-                          "Bcpl stores the highest vm page contained in this or earlier partition.")
-                               (NIL WORD)
-                               (NIL WORD)
-                               (XVmemDiskBase FULLXPOINTER)
-                                                             (* ; 
-      "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).")
-                               (NIL FULLXPOINTER)
-                               (NIL FULLXPOINTER)
-                               (DLLastVmemPage FIXP)
-                                                             (* ; 
-                                           "DLion booting microcode puts length of vmem file here.")
-                               (NActivePages FIXP)
-                                                             (* ; "Length of vmem in use")
-                               (NDirtyPages FIXP)
-                                                             (* ; 
-                                                       "not used, but maintained as = NActivePages")
-                               ))
-
-(RPAQQ IOPAGELAYOUT ((NIL 22Q WORD)
-                         (DLMAINTPANEL WORD NIL T)
-                         (DLFLOPPYCMD WORD)
-                         (DLTTYPORTCMD WORD)
-                         (DLPROCESSORCMD WORD)
-                         (NEWMOUSESTATE WORD)
-                         (DLBEEPCMD WORD)
-                         (DLRS232CMISCCOMMAND WORD)
-                         (DLRS232CPUTFLAG WORD)
-                         (DLRS232CGETFLAG WORD)
-                         (NIL 6 WORD)
-                         (DLFLOPPY WORD)
-                         (DLTTYOUT WORD)
-                         (NIL 1 WORD)
-                         (DLTTYIN WORD)
-                         (NIL 1 WORD)
-                         (DLPROCESSOR2 WORD)
-                         (DLPROCESSOR1 WORD)
-                         (DLPROCESSOR0 WORD)
-                         (NEWMOUSEX WORD)
-                         (NEWMOUSEY WORD)
-                         (DLBEEPFREQ WORD)
-                         (DLRS232CPARAMETERCSBLO WORD)
-                         (DLRS232CPARAMETERCSBHI WORD)
-                         (DLRS232CSETRS366STATUS 3 WORD)
-                         (DLRS232CPUTCSBLO WORD)
-                         (DLRS232CPUTCSBHI WORD)
-                         (DLRS232CGETCSBLO WORD)
-                         (DLRS232CGETCSBHI WORD)
-                         (DLRS232CDEVICESTATUS WORD)
-                         (DLRS232CPARAMETEROUTCOME WORD)
-                         (DLTODVALID WORD)
-                         (DLTODLO WORD NIL T)
-                         (DLTODHI WORD)
-                         (DLTODLO2 WORD)
-                         (DLMOUSEX WORD NIL T)
-                         (DLMOUSEY WORD NIL T)
-                         (DLUTILIN WORD NIL T)
-                         (DLKBDAD0 WORD NIL T)
-                         (DLKBDAD1 WORD NIL T)
-                         (DLKBDAD2 WORD NIL T)
-                         (DLKBDAD3 WORD NIL T)
-                         (DLKBDAD4 WORD NIL T)
-                         (DLKBDAD5 WORD NIL T)
-                         (DLLSEPIMAGECSB 40Q WORD)
-                         (DLIOPHARDWARECONFIG WORD)
-                         (NIL 13Q WORD)
-                         (DLRS232CPARAMETERCSBLO.11 WORD)
-                         (DLRS232CPARAMETERCSBHI.11 WORD)
-                         (DLRS232CSETRS366STATUS.11 16Q WORD)
-                         (NIL 74Q WORD)
-                         (DLMAGTAPE 4 WORD)
-                         (DLETHERNET 14Q WORD NIL T)
-                         (NIL 37Q WORD)
-                         (DLDISPINTERRUPT WORD NIL T)
-                         (DLDISPCONTROL WORD)
-                         (DLDISPBORDER WORD)
-                         (DLCURSORX WORD NIL T)
-                         (DLCURSORY WORD NIL T)
-                         (DLCURSORBITMAP 20Q WORD NIL T)))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ CDRCODING 1)
-
-(RPAQQ \SMALLP 1)
-
-(RPAQQ \FIXP 2)
-
-(RPAQQ \FLOATP 3)
-
-(RPAQQ \LITATOM 4)
-
-(RPAQQ \LISTP 5)
-
-(RPAQQ \ARRAYP 6)
-
-(RPAQQ \STRINGP 7)
-
-(RPAQQ \STACKP 10Q)
-
-(RPAQQ \CHARACTERP 11Q)
-
-(RPAQQ \VMEMPAGEP 12Q)
-
-(RPAQQ \STREAM 13Q)
-
-(RPAQQ \TT.TYPEMASK 3777Q)
-
-(RPAQQ \TT.NOREF 100000Q)
-
-(RPAQQ \TT.SYMBOLP 40000Q)
-
-(RPAQQ \TT.FIXP 20000Q)
-
-(RPAQQ \TT.NUMBERP 10000Q)
-
-(RPAQQ \TT.ATOM 4000Q)
-
-(RPAQQ \PMblockSize 40Q)
-
-(RPAQQ \STATSsize 10Q)
-
-(RPAQQ \NumPMTpages 10Q)
-
-(RPAQQ \EmptyPMTEntry 177777Q)
-
-(RPAQQ \FirstVmemBlock 2)
-
-(RPAQQ \MAXVMPAGE 377775Q)
-
-(RPAQQ \MAXVMSEGMENT 377Q)
-
-(RPAQQ \IFPValidKey 12743Q)
-
-(RPAQQ \FirstMDSPage 37776Q)
-
-(RPAQQ \MaxMDSPage 1777775Q)
-
-(RPAQQ \DefaultSecondMDSPage 177774Q)
-
-(RPAQQ \MDSIncrement 1000Q)
-
-(RPAQQ \PagesPerMDSUnit 2)
-
-(RPAQQ \FirstArraySegment 56Q)
-
-(RPAQQ \FirstArrayPage 27000Q)
-
-(RPAQQ \DefaultSecondArrayPage 40000Q)
-
-(RPAQQ \StackMask 160000Q)
-
-(RPAQQ \FxtnBlock 140000Q)
-
-(RPAQQ \GuardBlock 160000Q)
-
-(RPAQQ \BFBlock 100000Q)
-
-(RPAQQ \FreeStackBlock 120000Q)
-
-(RPAQQ \NotStackBlock 0)
-
-(RPAQQ \MinExtraStackWords 40Q)
-
-(RPAQQ ERASECHARCODE 0)
-
-(RPAQQ \HT1CNT 2000Q)
-
-(RPAQQ \HTSTKBIT 1000Q)
-
-(RPAQQ \HTCNTMASK 176000Q)
-
-(RPAQQ \HTMAINSIZE 200000Q)
-
-(RPAQQ \HTCOLLSIZE 4000000Q)
-
-(RPAQQ \HTENDFREE 1)
-
-(RPAQQ \HTFREEPTR 0)
-
-(RPAQQ \AtomHI 0)
-
-(RPAQQ \CHARHI 7)
-
-(RPAQQ \AtomHTpages 400Q)
-
-(RPAQQ \LastAtomPage 377Q)
-
-(RPAQQ \MaxAtomFrLst 177777Q)
-
-(RPAQQ \SmallPosHi 16Q)
-
-(RPAQQ \SmallNegHi 17Q)
-
-(RPAQQ \NumSmallPages 1000Q)
-
-(RPAQQ \PNAME.HI 10Q)
-
-(RPAQQ \ATOM.HI 54Q)
-
-(RPAQQ \DEF.HI 12Q)
-
-(RPAQQ \VAL.HI 14Q)
-
-(RPAQQ \PLIST.HI 2)
-
-(RPAQQ \NumPageMapPages 400Q)
-
-(RPAQQ \MDSTTsize 2000Q)
-
-(RPAQQ \UFNTableSize 2)
-
-(RPAQQ \DTDSize 22Q)
-
-(RPAQQ \EndTypeNumber 3777Q)
-
-(RPAQQ \NumLPTPages 20Q)
-
-(RPAQQ \GuardStackAddr 170000Q)
-
-(RPAQQ \LastStackAddr 177776Q)
-
-(RPAQQ \STACKHI 1)
-
-(RPAQQ \HTMAINnpages 400Q)
-
-(RPAQQ \D1BCPLspace 0)
-
-(RPAQQ \D0BCPLspace 0)
-
-(RPAQQ \CurrentFXP 0)
-
-(RPAQQ \ResetFXP 1)
-
-(RPAQQ \SubovFXP 2)
-
-(RPAQQ \KbdFXP 3)
-
-(RPAQQ \HardReturnFXP 4)
-
-(RPAQQ \GCFXP 5)
-
-(RPAQQ \FAULTFXP 6)
-
-(RPAQQ \MiscFXP 16Q)
-
-(RPAQQ \TeleRaidFXP 30Q)
-
-(RPAQQ DCB.EM 420Q)
-
-(RPAQQ DISPINTERRUPT.EM 421Q)
-
-(RPAQQ CURSORBITMAP.EM 431Q)
-
-(RPAQQ KBDAD0.EM 177034Q)
-
-(RPAQQ KBDAD1.EM 177035Q)
-
-(RPAQQ KBDAD2.EM 177036Q)
-
-(RPAQQ KBDAD3.EM 177037Q)
-
-(RPAQQ UTILIN.EM 177030Q)
-
-(RPAQQ CURSORX.EM 426Q)
-
-(RPAQQ CURSORY.EM 427Q)
-
-(RPAQQ MOUSEX.EM 424Q)
-
-(RPAQQ MOUSEY.EM 425Q)
-
-(RPAQQ \LispKeyMask 20000Q)
-
-(RPAQQ \BcplKeyMask 10400Q)
-
-(RPAQQ \MAIKO 3)
-
-(RPAQQ \DOLPHIN 4)
-
-(RPAQQ \DORADO 5)
-
-(RPAQQ \DANDELION 6)
-
-(RPAQQ \DAYBREAK 10Q)
-
-(RPAQQ \VP.DISPLAY 11000Q)
-
-(RPAQQ \NP.DISPLAY 312Q)
-
-(RPAQQ \NP.WIDEDOVEDISPLAY 363Q)
-
-(RPAQQ \WIDEDOVEDISPLAYWIDTH 2200Q)
-
-(RPAQQ \RP.AFTERDISPLAY 316Q)
-
-(RPAQQ \RP.AFTERDOVEDISPLAY 363Q)
-
-(RPAQQ \RP.DISPLAY 0)
-
-(RPAQQ \RP.TEMPDISPLAY 5001Q)
-
-(RPAQQ \RP.MISCLOCKED 5364Q)
-
-(RPAQQ \RP.STACK 1400Q)
-
-(RPAQQ \VP.STACK 400Q)
-
-(RPAQQ \RP.MAP 400Q)
-
-(RPAQQ \NP.MAP 400Q)
-
-(RPAQQ \RP.IOPAGE 1000Q)
-
-(RPAQQ \RP.DOVEIOCBPAGE 1037Q)
-
-(RPAQQ \RP.DOVEIORGN 1040Q)
-
-(RPAQQ \VP.DOVEIORGN 100Q)
-
-(RPAQQ \DOVEIORGNSIZE 100Q)
-
-(RPAQQ \VP.IOPAGE 377Q)
-
-(RPAQQ \VP.IFPAGE 12000Q)
-
-(RPAQQ \VP.FPTOVP 1000Q)
-
-(RPAQQ \NP.FPTOVP 10000Q)
-
-(RPAQQ \RP.FPTOVP 2000Q)
-
-(RPAQQ \RP.STARTBUFFERS 1200Q)
-
-(RPAQQ \VP.TYPETABLE 14000Q)
-
-(RPAQQ \NP.TYPETABLE 2000Q)
-
-(RPAQQ \RP.TYPETABLE 12000Q)
-
-(RPAQQ \VP.GCTABLE 13000Q)
-
-(RPAQQ \NP.GCTABLE 400Q)
-
-(RPAQQ \RP.GCTABLE 14000Q)
-
-(RPAQQ \VP.GCOVERFLOW 13400Q)
-
-(RPAQQ \NP.GCOVERFLOW 1)
-
-(RPAQQ \RP.GCOVERFLOW 14400Q)
-
-(RPAQQ \FP.IFPAGE 2)
-
-(RPAQQ \VP.IOCBS 1)
-
-(RPAQQ \VP.PRIMARYMAP 12002Q)
-
-(RPAQQ \VP.SECONDARYMAP 2400Q)
-
-(RPAQQ \VP.LPT 12160Q)
-
-(RPAQQ \VP.INITSCRATCH 10Q)
-
-(RPAQQ \VP.RPT 200Q)
-
-(RPAQQ \VP.BUFFERS 332Q)
-
-(RPAQQ \DL.PROCESSORBUSY 100000Q)
-
-(RPAQQ \DL.SETTOD 100001Q)
-
-(RPAQQ \DL.READTOD 100002Q)
-
-(RPAQQ \DL.READPID 100003Q)
-
-(RPAQQ \DL.BOOTBUTTON 100004Q)
-
-
-(CONSTANTS (CDRCODING 1)
-       (\SMALLP 1)
-       (\FIXP 2)
-       (\FLOATP 3)
-       (\LITATOM 4)
-       (\LISTP 5)
-       (\ARRAYP 6)
-       (\STRINGP 7)
-       (\STACKP 10Q)
-       (\CHARACTERP 11Q)
-       (\VMEMPAGEP 12Q)
-       (\STREAM 13Q)
-       (\TT.TYPEMASK 3777Q)
-       (\TT.NOREF 100000Q)
-       (\TT.SYMBOLP 40000Q)
-       (\TT.FIXP 20000Q)
-       (\TT.NUMBERP 10000Q)
-       (\TT.ATOM 4000Q)
-       (\PMblockSize 40Q)
-       (\STATSsize 10Q)
-       (\NumPMTpages 10Q)
-       (\EmptyPMTEntry 177777Q)
-       (\FirstVmemBlock 2)
-       (\MAXVMPAGE 377775Q)
-       (\MAXVMSEGMENT 377Q)
-       (\IFPValidKey 12743Q)
-       (\FirstMDSPage 37776Q)
-       (\MaxMDSPage 1777775Q)
-       (\DefaultSecondMDSPage 177774Q)
-       (\MDSIncrement 1000Q)
-       (\PagesPerMDSUnit 2)
-       (\FirstArraySegment 56Q)
-       (\FirstArrayPage 27000Q)
-       (\DefaultSecondArrayPage 40000Q)
-       (\StackMask 160000Q)
-       (\FxtnBlock 140000Q)
-       (\GuardBlock 160000Q)
-       (\BFBlock 100000Q)
-       (\FreeStackBlock 120000Q)
-       (\NotStackBlock 0)
-       (\MinExtraStackWords 40Q)
-       (ERASECHARCODE 0)
-       (\HT1CNT 2000Q)
-       (\HTSTKBIT 1000Q)
-       (\HTCNTMASK 176000Q)
-       (\HTMAINSIZE 200000Q)
-       (\HTCOLLSIZE 4000000Q)
-       (\HTENDFREE 1)
-       (\HTFREEPTR 0)
-       (\AtomHI 0)
-       (\CHARHI 7)
-       (\AtomHTpages 400Q)
-       (\LastAtomPage 377Q)
-       (\MaxAtomFrLst 177777Q)
-       (\SmallPosHi 16Q)
-       (\SmallNegHi 17Q)
-       (\NumSmallPages 1000Q)
-       (\PNAME.HI 10Q)
-       (\ATOM.HI 54Q)
-       (\DEF.HI 12Q)
-       (\VAL.HI 14Q)
-       (\PLIST.HI 2)
-       (\NumPageMapPages 400Q)
-       (\MDSTTsize 2000Q)
-       (\UFNTableSize 2)
-       (\DTDSize 22Q)
-       (\EndTypeNumber 3777Q)
-       (\NumLPTPages 20Q)
-       (\GuardStackAddr 170000Q)
-       (\LastStackAddr 177776Q)
-       (\STACKHI 1)
-       (\HTMAINnpages 400Q)
-       (\D1BCPLspace 0)
-       (\D0BCPLspace 0)
-       (\CurrentFXP 0)
-       (\ResetFXP 1)
-       (\SubovFXP 2)
-       (\KbdFXP 3)
-       (\HardReturnFXP 4)
-       (\GCFXP 5)
-       (\FAULTFXP 6)
-       (\MiscFXP 16Q)
-       (\TeleRaidFXP 30Q)
-       (DCB.EM 420Q)
-       (DISPINTERRUPT.EM 421Q)
-       (CURSORBITMAP.EM 431Q)
-       (KBDAD0.EM 177034Q)
-       (KBDAD1.EM 177035Q)
-       (KBDAD2.EM 177036Q)
-       (KBDAD3.EM 177037Q)
-       (UTILIN.EM 177030Q)
-       (CURSORX.EM 426Q)
-       (CURSORY.EM 427Q)
-       (MOUSEX.EM 424Q)
-       (MOUSEY.EM 425Q)
-       (\LispKeyMask 20000Q)
-       (\BcplKeyMask 10400Q)
-       (\MAIKO 3)
-       (\DOLPHIN 4)
-       (\DORADO 5)
-       (\DANDELION 6)
-       (\DAYBREAK 10Q)
-       (\VP.DISPLAY 11000Q)
-       (\NP.DISPLAY 312Q)
-       (\NP.WIDEDOVEDISPLAY 363Q)
-       (\WIDEDOVEDISPLAYWIDTH 2200Q)
-       (\RP.AFTERDISPLAY 316Q)
-       (\RP.AFTERDOVEDISPLAY 363Q)
-       (\RP.DISPLAY 0)
-       (\RP.TEMPDISPLAY 5001Q)
-       (\RP.MISCLOCKED 5364Q)
-       (\RP.STACK 1400Q)
-       (\VP.STACK 400Q)
-       (\RP.MAP 400Q)
-       (\NP.MAP 400Q)
-       (\RP.IOPAGE 1000Q)
-       (\RP.DOVEIOCBPAGE 1037Q)
-       (\RP.DOVEIORGN 1040Q)
-       (\VP.DOVEIORGN 100Q)
-       (\DOVEIORGNSIZE 100Q)
-       (\VP.IOPAGE 377Q)
-       (\VP.IFPAGE 12000Q)
-       (\VP.FPTOVP 1000Q)
-       (\NP.FPTOVP 10000Q)
-       (\RP.FPTOVP 2000Q)
-       (\RP.STARTBUFFERS 1200Q)
-       (\VP.TYPETABLE 14000Q)
-       (\NP.TYPETABLE 2000Q)
-       (\RP.TYPETABLE 12000Q)
-       (\VP.GCTABLE 13000Q)
-       (\NP.GCTABLE 400Q)
-       (\RP.GCTABLE 14000Q)
-       (\VP.GCOVERFLOW 13400Q)
-       (\NP.GCOVERFLOW 1)
-       (\RP.GCOVERFLOW 14400Q)
-       (\FP.IFPAGE 2)
-       (\VP.IOCBS 1)
-       (\VP.PRIMARYMAP 12002Q)
-       (\VP.SECONDARYMAP 2400Q)
-       (\VP.LPT 12160Q)
-       (\VP.INITSCRATCH 10Q)
-       (\VP.RPT 200Q)
-       (\VP.BUFFERS 332Q)
-       (\DL.PROCESSORBUSY 100000Q)
-       (\DL.SETTOD 100001Q)
-       (\DL.READTOD 100002Q)
-       (\DL.READPID 100003Q)
-       (\DL.BOOTBUTTON 100004Q))
-)
-
-(RPAQQ \MPERRORS ((\MP.OBSOLETEVMEM 1)
-                      (\MP.INVALIDVMEM 2 "Vmem inconsistent at startup")
-                      (\MP.IOCBPAGE 3 "No place for IOCB page at startup")
-                      (\MP.MOB 4 "Map out of bounds")
-                      (\MP.INVALIDADDR 5)
-                      (\MP.INVALIDVP 6)
-                      (\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain")
-                      (\MP.SELECTLOOP 10Q "Loop in \SELECTREALPAGE")
-                      (\MP.NEWPAGE 11Q "Attempt to allocate already existing page")
-                      (\MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page")
-                      (\MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another")
-                      (\MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box")
-                      (\MP.RESIDENT 15Q "Fault on resident page")
-                      (\MP.STACKFAULT 16Q "Fault on stack")
-                      (\MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)")
-                      (\MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T")
-                      (\MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code")
-                      (\MP.STACKFULL 23Q)
-                      (\MP.MDSFULL 24Q)
-                      (\MP.UNKNOWN.UFN 25Q)
-                      (\MP.ATOMSFULL 26Q)
-                      (\MP.PNAMESFULL 27Q)
-                      (\MP.USECOUNTOVERFLOW 30Q)
-                      (\MP.MDSFULLWARNING 31Q)
-                      (\MP.BADMDSFREELIST 32Q)
-                      (\MP.BADARRAYBLOCK 33Q)
-                      (\MP.BADDELETEBLOCK 34Q)
-                      (\MP.BADARRAYRECLAIM 35Q)
-                      (\MP.BIGREFCNTMISSING 36Q 
-                             "PTR refcnt previously overflowed, but not found in table.")
-                      (\MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table")
-                      (\MP.DELREF0 40Q)
-                      (\MP.PROCERROR 41Q)
-                      (\MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use")
-                      (\MP.32MBINUSE 43Q)
-                      (\MP.TOPUNWOUND 44Q "Unexpected (RETTO T)")
-                      (\MP.STACKRELEASED 45Q)
-                      (\MP.FLUSHLOCKED 46Q)
-                      (\MP.MAPNOTLOCKED 47Q)
-                      (\MP.UNLOCKINGMAP 50Q)
-                      (\MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper")
-                      (\MP.BADRUNTABLE 52Q "Malformed run table for vmem file")))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \MP.OBSOLETEVMEM 1)
-
-(RPAQ \MP.INVALIDVMEM 2 "Vmem inconsistent at startup")
-
-(RPAQ \MP.IOCBPAGE 3 "No place for IOCB page at startup")
-
-(RPAQ \MP.MOB 4 "Map out of bounds")
-
-(RPAQQ \MP.INVALIDADDR 5)
-
-(RPAQQ \MP.INVALIDVP 6)
-
-(RPAQ \MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain")
-
-(RPAQ \MP.SELECTLOOP 10Q "Loop in \SELECTREALPAGE")
-
-(RPAQ \MP.NEWPAGE 11Q "Attempt to allocate already existing page")
-
-(RPAQ \MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page")
-
-(RPAQ \MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another")
-
-(RPAQ \MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box")
-
-(RPAQ \MP.RESIDENT 15Q "Fault on resident page")
-
-(RPAQ \MP.STACKFAULT 16Q "Fault on stack")
-
-(RPAQ \MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)")
-
-(RPAQ \MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T")
-
-(RPAQ \MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code")
-
-(RPAQQ \MP.STACKFULL 23Q)
-
-(RPAQQ \MP.MDSFULL 24Q)
-
-(RPAQQ \MP.UNKNOWN.UFN 25Q)
-
-(RPAQQ \MP.ATOMSFULL 26Q)
-
-(RPAQQ \MP.PNAMESFULL 27Q)
-
-(RPAQQ \MP.USECOUNTOVERFLOW 30Q)
-
-(RPAQQ \MP.MDSFULLWARNING 31Q)
-
-(RPAQQ \MP.BADMDSFREELIST 32Q)
-
-(RPAQQ \MP.BADARRAYBLOCK 33Q)
-
-(RPAQQ \MP.BADDELETEBLOCK 34Q)
-
-(RPAQQ \MP.BADARRAYRECLAIM 35Q)
-
-(RPAQ \MP.BIGREFCNTMISSING 36Q "PTR refcnt previously overflowed, but not found in table.")
-
-(RPAQ \MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table")
-
-(RPAQQ \MP.DELREF0 40Q)
-
-(RPAQQ \MP.PROCERROR 41Q)
-
-(RPAQ \MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use")
-
-(RPAQQ \MP.32MBINUSE 43Q)
-
-(RPAQ \MP.TOPUNWOUND 44Q "Unexpected (RETTO T)")
-
-(RPAQQ \MP.STACKRELEASED 45Q)
-
-(RPAQQ \MP.FLUSHLOCKED 46Q)
-
-(RPAQQ \MP.MAPNOTLOCKED 47Q)
-
-(RPAQQ \MP.UNLOCKINGMAP 50Q)
-
-(RPAQ \MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper")
-
-(RPAQ \MP.BADRUNTABLE 52Q "Malformed run table for vmem file")
-
-
-(CONSTANTS (\MP.OBSOLETEVMEM 1)
-       (\MP.INVALIDVMEM 2 "Vmem inconsistent at startup")
-       (\MP.IOCBPAGE 3 "No place for IOCB page at startup")
-       (\MP.MOB 4 "Map out of bounds")
-       (\MP.INVALIDADDR 5)
-       (\MP.INVALIDVP 6)
-       (\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain")
-       (\MP.SELECTLOOP 10Q "Loop in \SELECTREALPAGE")
-       (\MP.NEWPAGE 11Q "Attempt to allocate already existing page")
-       (\MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page")
-       (\MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another")
-       (\MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box")
-       (\MP.RESIDENT 15Q "Fault on resident page")
-       (\MP.STACKFAULT 16Q "Fault on stack")
-       (\MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)")
-       (\MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T")
-       (\MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code")
-       (\MP.STACKFULL 23Q)
-       (\MP.MDSFULL 24Q)
-       (\MP.UNKNOWN.UFN 25Q)
-       (\MP.ATOMSFULL 26Q)
-       (\MP.PNAMESFULL 27Q)
-       (\MP.USECOUNTOVERFLOW 30Q)
-       (\MP.MDSFULLWARNING 31Q)
-       (\MP.BADMDSFREELIST 32Q)
-       (\MP.BADARRAYBLOCK 33Q)
-       (\MP.BADDELETEBLOCK 34Q)
-       (\MP.BADARRAYRECLAIM 35Q)
-       (\MP.BIGREFCNTMISSING 36Q "PTR refcnt previously overflowed, but not found in table.")
-       (\MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table")
-       (\MP.DELREF0 40Q)
-       (\MP.PROCERROR 41Q)
-       (\MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use")
-       (\MP.32MBINUSE 43Q)
-       (\MP.TOPUNWOUND 44Q "Unexpected (RETTO T)")
-       (\MP.STACKRELEASED 45Q)
-       (\MP.FLUSHLOCKED 46Q)
-       (\MP.MAPNOTLOCKED 47Q)
-       (\MP.UNLOCKINGMAP 50Q)
-       (\MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper")
-       (\MP.BADRUNTABLE 52Q "Malformed run table for vmem file"))
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \ARRAYSPACE \ARRAYSPACE2 \ATOMSPACE \AtomHashTable \SMALLPOSPSPACE \SMALLNEGSPACE 
-       \PNPSPACE \OLDATOMSPACE \DEFSPACE \VALSPACE \PLISTSPACE \PAGEMAP \PageMapTBL \InterfacePage 
-       \IOPAGE \DoveIORegion \IOCBPAGE \FPTOVP \MDSTypeTable \MISCSTATS \UFNTable \DTDSpaceBase 
-       \LISTPDTD \LOCKEDPAGETABLE \STACKSPACE \HTMAIN \HTOVERFLOW \HTBIGCOUNT \HTCOLL \DISPLAYREGION)
-)
-
-(BLOCKRECORD MISCSTATS ((STARTTIME FIXP)
-                        (TOTALTIME FIXP)
-                        (SWAPWAITTIME FIXP)
-                        (PAGEFAULTS FIXP)
-                        (SWAPWRITES FIXP)
-                        (DISKIOTIME FIXP)
-                        (DISKOPS FIXP)
-                        (KEYBOARDWAITTIME FIXP)
-                        (GCTIME FIXP)
-                        (NETIOTIME FIXP)
-                        (NETIOOPS FIXP)
-                        (SWAPTEMP0 FIXP)
-                        (SWAPTEMP1 FIXP)
-                        (RCLKSECOND FIXP)
-                        (SECONDSCLOCK FIXP)
-                        (MILLISECONDSCLOCK FIXP)
-                        (BASECLOCK FIXP)
-                        (RCLKTEMP0 FIXP)
-                        (SECONDSTMP FIXP)
-                        (MILLISECONDSTMP FIXP)
-                        (BASETMP FIXP)
-                        (EXCESSTIMETMP FIXP)
-                        (CLOCKTEMP0 FIXP)
-                        (DISKTEMP0 FIXP)
-                        (DISKTEMP1 FIXP)
-                        (TELERAIDTEMP1 FIXP)
-                        (TELERAIDTEMP2 FIXP)
-                        (TELERAIDTEMP3 FIXP)
-                        (LASTUSERACTION FIXP)
-                        (DLMOUSETIMER FIXP)
-                        (DLMOUSETEMP FIXP))
-       (CREATE (\ALLOCBLOCK 37Q)))
-
-(BLOCKRECORD IFPAGE ((CurrentFXP WORD)                       (* ; 
-                                      "First 7 items are FX values for user and 6 system contexts.")
-                     (ResetFXP WORD)
-                     (SubovFXP WORD)
-                     (KbdFXP WORD)
-                     (HardReturnFXP WORD)
-                     (GCFXP WORD)
-                     (FAULTFXP WORD)
-                     (EndOfStack WORD)                       (* ; 
-                            "Stack high-water mark: address of guard block at current end of stack")
-                     (LVersion WORD)                         (* ; 
-           "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp")
-                     (MinRVersion WORD)
-                     (MinBVersion WORD)
-                     (RVersion WORD)                         (* ; 
-                                               "Bcpl fills in the actual microcode, Bcpl versions.")
-                     (BVersion WORD)
-                     (MachineType WORD)
-                     (MiscFXP WORD)                          (* ; "FX for MISC context")
-                     (Key WORD)                              (* ; 
-                                                           "= IFPValidKey if vmem consistent.")
-                     (SerialNumber WORD)                     (* ; 
-                                                           "Pup host number (Dorado/Dolphin)")
-                     (EmulatorSpace WORD)                    (* ; 
-                                                           "Hiloc of bcpl space (always zero now)")
-                     (ScreenWidth WORD)
-                     (NxtPMAddr WORD)                        (* ; 
-                                            "Next page to be allocated in secondary page map table")
-                     (NIL WORD)                              (* ; 
-                                                          "WAS NActivePages, Length of vmem in use")
-                     (NIL WORD)                              (* ; 
-                                      "WAS NDirtyPages, not used, but maintained as = NActivePages")
-                     (filePnPMP0 WORD)                       (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live")
-                     (filePnPMT0 WORD)                       (* ; 
-                                       "Sysout page number of first page of primary page map table")
-                     (TELERAIDFXP WORD)                      (* ; "FX for TeleRaid server context")
-                     (NATIVE-START-MEM-PAGE WORD)            (* ; 
-                                                           "Unix page where native code starts")
-                     (NATIVE-LENGTH-PAGE WORD)               (* ; "Unix page length of native code")
-                     (NATIVE-PAGE-OFFSET WORD)               (* ; 
-                                                           "Lisp Disk Page offset  of native code")
-                     (UserNameAddr WORD)                     (* ; 
-                                 "Addresses in bcpl space (seg 0) of global user name and password")
-                     (UserPswdAddr WORD)
-                     (StackBase WORD)                        (* ; 
-                                                           "Stack address where user stack starts")
-                     (FAULTHI WORD)                          (* ; 
-         "Microcode for page fault stores fault address here, then does context switch to FAULTFXP")
-                     (FAULTLO WORD)
-                     (DEVCONFIG WORD)                        (* ; "IT'S FOR KB,DISP TYPE")
-                                                             (* ; 
-                                   "Formerly REALPAGETABLE, back when it was always in Bcpl space.")
-                     (RPTSIZE WORD)                          (* ; 
-                                                           "Number of entries in Real Page Table")
-                     (RPOFFSET WORD)                         (* ; "RP-RPOFFSET => index in table")
-                     (MAXETHERBYTES WORD)                    (* ; 
-                          "Number of bytes available in a pbi, not counting encapsulation (Dorado)")
-                     (EMBUFVP WORD)                          (* ; 
-                                                           "VP of a one-page emulator buffer")
-                     (NSHost0 WORD)                          (* ; "Machine's 48-bit NS host number.  Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in.")
-                     (NSHost1 WORD)
-                     (NSHost2 WORD)
-                     (MDSZone WORD)                          (* ; 
-                                               "Obsolete -- was used by Dolphin 10MB network code.")
-                     (MDSZoneLength WORD)
-                     (EMUBUFFERS WORD)                       (* ; 
-                                             "Buffer space in segment 0 for swapping/disk activity")
-                     (EMUBUFLENGTH WORD)                     (* ; "Number of words of said space")
-
-                     (* ;; "The following 2 are available if NEW_STOARGE is specified in C")
-
-                     (ProcessSize WORD)                      (* ; 
-                                                  "Process size for which can be use as LISP space")
-                     (StorageFullState WORD)                 (* ; "Save last storage state")
-                     (ISFMAP WORD)
-
-                     (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!")
-
-                     (MISCSTACKFN FULLXPOINTER)
-                     (MISCSTACKARG1 FULLXPOINTER)
-                     (MISCSTACKARG2 FULLXPOINTER)
-                     (MISCSTACKRESULT FULLXPOINTER)
-                     (NRealPages WORD)                       (* ; "Number pages of real memory")
-                     (LastLockedFilePage WORD)               (* ; 
-                         "Last page of vmem that is locked--booting has to load at least that far.")
-                     (LastDominoFilePage WORD)               (* ; 
-                                                "Last sysout page reserved for Dandelion microcode")
-                     (FPTOVPStart WORD)                      (* ; "Sysout page where FPTOVP starts")
-                     (FAKEMOUSEBITS WORD)                    (* ; 
-                                      "Used to implement fake middle button on 2-button Dandelion.")
-                     (DL24BitAddressable WORD)               (* ; 
-                                      "non-zero if DLion capable of addressing 32MB virtual memory")
-                     (REALPAGETABLEPTR FULLXPOINTER)         (* ; 
-                            "Address of real page table, set up by Bcpl (but not chained together)")
-                     (SYSDISK WORD)                          (* ; 
-                       "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.")
-                     (FullSpaceUsed WORD)                    (* ; 
-                                          "Non-zero if vmem beyond initial 8MB has been allocated.")
-                     (FAKEKBDAD4 WORD)
-                     (FAKEKBDAD5 WORD)
-
-                     (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with.")
-
-                     (XVmemFmapBase WORD)                    (* ; 
- "Bcpl stores isf map pointer to each partition here.  First is redundant with ISFMAP field above.")
-                     (NIL WORD)
-                     (NIL WORD)
-                     (XVmemFmapHighBase WORD)                (* ; 
-                          "Bcpl stores the highest vm page contained in this or earlier partition.")
-                     (NIL WORD)
-                     (NIL WORD)
-                     (XVmemDiskBase FULLXPOINTER)            (* ; 
-      "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).")
-                     (NIL FULLXPOINTER)
-                     (NIL FULLXPOINTER)
-                     (DLLastVmemPage FIXP)                   (* ; 
-                                           "DLion booting microcode puts length of vmem file here.")
-                     (NActivePages FIXP)                     (* ; "Length of vmem in use")
-                     (NDirtyPages FIXP)                      (* ; 
-                                                       "not used, but maintained as = NActivePages")
-                     )
-       (CREATE (\ALLOCBLOCK 53Q)))
-
-(BLOCKRECORD IOPAGE ((NIL 22Q WORD)
-                     (DLMAINTPANEL WORD)
-                     (DLFLOPPYCMD WORD)
-                     (DLTTYPORTCMD WORD)
-                     (DLPROCESSORCMD WORD)
-                     (NEWMOUSESTATE WORD)
-                     (DLBEEPCMD WORD)
-                     (DLRS232CMISCCOMMAND WORD)
-                     (DLRS232CPUTFLAG WORD)
-                     (DLRS232CGETFLAG WORD)
-                     (NIL 6 WORD)
-                     (DLFLOPPY WORD)
-                     (DLTTYOUT WORD)
-                     (NIL 1 WORD)
-                     (DLTTYIN WORD)
-                     (NIL 1 WORD)
-                     (DLPROCESSOR2 WORD)
-                     (DLPROCESSOR1 WORD)
-                     (DLPROCESSOR0 WORD)
-                     (NEWMOUSEX WORD)
-                     (NEWMOUSEY WORD)
-                     (DLBEEPFREQ WORD)
-                     (DLRS232CPARAMETERCSBLO WORD)
-                     (DLRS232CPARAMETERCSBHI WORD)
-                     (DLRS232CSETRS366STATUS 3 WORD)
-                     (DLRS232CPUTCSBLO WORD)
-                     (DLRS232CPUTCSBHI WORD)
-                     (DLRS232CGETCSBLO WORD)
-                     (DLRS232CGETCSBHI WORD)
-                     (DLRS232CDEVICESTATUS WORD)
-                     (DLRS232CPARAMETEROUTCOME WORD)
-                     (DLTODVALID WORD)
-                     (DLTODLO WORD)
-                     (DLTODHI WORD)
-                     (DLTODLO2 WORD)
-                     (DLMOUSEX WORD)
-                     (DLMOUSEY WORD)
-                     (DLUTILIN WORD)
-                     (DLKBDAD0 WORD)
-                     (DLKBDAD1 WORD)
-                     (DLKBDAD2 WORD)
-                     (DLKBDAD3 WORD)
-                     (DLKBDAD4 WORD)
-                     (DLKBDAD5 WORD)
-                     (DLLSEPIMAGECSB 40Q WORD)
-                     (DLIOPHARDWARECONFIG WORD)
-                     (NIL 13Q WORD)
-                     (DLRS232CPARAMETERCSBLO.11 WORD)
-                     (DLRS232CPARAMETERCSBHI.11 WORD)
-                     (DLRS232CSETRS366STATUS.11 16Q WORD)
-                     (NIL 74Q WORD)
-                     (DLMAGTAPE 4 WORD)
-                     (DLETHERNET 14Q WORD)
-                     (NIL 37Q WORD)
-                     (DLDISPINTERRUPT WORD)
-                     (DLDISPCONTROL WORD)
-                     (DLDISPBORDER WORD)
-                     (DLCURSORX WORD)
-                     (DLCURSORY WORD)
-                     (DLCURSORBITMAP 20Q WORD))
-       [ACCESSFNS IOPAGE ((DLCURSORBITMAPPTR (\ADDBASE DATUM 360Q))
-                          (DLCURSORYPTR (\ADDBASE DATUM 357Q))
-                          (DLCURSORXPTR (\ADDBASE DATUM 356Q))
-                          (DLDISPINTERRUPTPTR (\ADDBASE DATUM 353Q))
-                          (DLETHERNETPTR (\ADDBASE DATUM 300Q))
-                          (DLKBDAD5PTR (\ADDBASE DATUM 103Q))
-                          (DLKBDAD4PTR (\ADDBASE DATUM 102Q))
-                          (DLKBDAD3PTR (\ADDBASE DATUM 101Q))
-                          (DLKBDAD2PTR (\ADDBASE DATUM 100Q))
-                          (DLKBDAD1PTR (\ADDBASE DATUM 77Q))
-                          (DLKBDAD0PTR (\ADDBASE DATUM 76Q))
-                          (DLUTILINPTR (\ADDBASE DATUM 75Q))
-                          (DLMOUSEYPTR (\ADDBASE DATUM 74Q))
-                          (DLMOUSEXPTR (\ADDBASE DATUM 73Q))
-                          (DLTODLOPTR (\ADDBASE DATUM 70Q))
-                          (DLMAINTPANELPTR (\ADDBASE DATUM 22Q]
-       (CREATE (\ALLOCBLOCK 200Q)))
-(DECLARE%: EVAL@COMPILE 
-
-[PUTPROPS EMADDRESS MACRO (ARGS ([LAMBDA (ADDR)
-                                   (COND
-                                      [(EQ \D1BCPLspace \D0BCPLspace)
-                                       (LIST (BIG-VMEM-CODE (LIST 'OPCODES 'GCONST 0 0
-                                                                  (LRSH ADDR 10Q)
-                                                                  (LOGAND ADDR 377Q))
-                                                    (LIST 'OPCODES 'GCONST 0 (LRSH ADDR 10Q)
-                                                          (LOGAND ADDR 377Q]
-                                      (T `(\VAG2 (fetch EmulatorSpace of \InterfacePage)
-                                                 %, ADDR]
-                                 (EVAL (CAR ARGS]
-
-(PUTPROPS EMGETBASE MACRO ((OFFSET)
-                           (\GETBASE (EMADDRESS OFFSET)
-                                  0)))
-
-(PUTPROPS EMPUTBASE MACRO ((OFFSET VAL)
-                           (\PUTBASE (EMADDRESS OFFSET)
-                                  0 VAL)))
-
-(PUTPROPS EMULATORSEGMENT MACRO (NIL (fetch EmulatorSpace of \InterfacePage)))
-
-[PUTPROPS EMPOINTER MACRO (X (COND
-                                ((NEQ \D1BCPLspace \D0BCPLspace)
-                                 (LIST '\VAG2 '(fetch (IFPAGE EmulatorSpace) of 
-                                                                                       \InterfacePage
-                                                      )
-                                       (CAR X)))
-                                ((ZEROP (CAR X))
-                                 NIL)
-                                (T (LIST '\VAG2 \D0BCPLspace (CAR X]
-
-[PUTPROPS EMADDRESSP MACRO (X (LIST 'EQ (LIST '\HILOC (CAR X))
-                                    (COND
-                                       ((EQ \D1BCPLspace \D0BCPLspace)
-                                        \D0BCPLspace)
-                                       (T '(fetch (IFPAGE EmulatorSpace) of \InterfacePage]
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-)
-
-(PUTPROPS LLPARAMS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10Q))
-(PUTPROPS LLPARAMS COPYRIGHT (
-"Syntelligence Systems, Inc.  This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc.  Reverse engineering, reverse compiling and disassembling of object code are prohibited.  Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc.  Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets"
- 3675Q 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 3706Q 3707Q 3710Q 3712Q 3716Q))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (7177Q 13221Q (MAKERECORD 7211Q . 13217Q)))))
-STOP
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 8)
(FILECREATED " 7-Feb-2021 11:52:02" {DSK}<home>larry>ilisp>medley>sources>LLPARAMS.;3 206133Q

      changes to%:  (MACROS EMADDRESS)

      previous date%: "31-Jan-98 09:16:51" {DSK}<home>larry>ilisp>medley>sources>LLPARAMS.;2)


(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 (LIST 'OPCODES 'GCONST 0 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))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (5274Q 11316Q (MAKERECORD 5306Q . 11314Q)))))
STOP
\ No newline at end of file
diff --git a/sources/LLPARAMS.LCOM b/sources/LLPARAMS.LCOM
index 4765c1db..5685de27 100644
Binary files a/sources/LLPARAMS.LCOM and b/sources/LLPARAMS.LCOM differ
diff --git a/sources/LLSUBRS b/sources/LLSUBRS
index b9dcbf8f..ce9304e5 100644
--- a/sources/LLSUBRS
+++ b/sources/LLSUBRS
@@ -1 +1 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Dec-92 14:28:41" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>LLSUBRS.;15| 21492  

      changes to%:  (RECORDS MISCN-UFN-ENTRY)

      previous date%: "21-Feb-92 12:54:44" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>LLSUBRS.;14|)


(* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1988, 1989, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT LLSUBRSCOMS)

(RPAQQ LLSUBRSCOMS
       ((DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME 
                                                         WRITECALLSUBRS)))
        

(* ;;; "MISCN  Vars & Functions")

        (EXPORT (VARS \MISCN-TABLE-LIST))
        (FUNCTIONS MISCN)
        (OPTIMIZERS MISCN)
        (FNS MISCN-NUMBER \MISCN.UFN \UNDEFINED-MISCN-UFN MISCN-COLLECT \GET-MY-BF \INIT-MISCN-TABLE)
        (PROP ARGNAMES MISCN)
        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MISCN-UFN-SPEC MISCN-UFN-ENTRY))
        

(* ;;; " USER-SUBR Vars & Functions")

        (EXPORT (VARS \USER-SUBR-LIST))
        (FUNCTIONS USER-SUBR ADD-USER-SUBR)
        (FNS \USER-SUBR-UFN \INIT-USER-SUBR-TABLE \UNDEFINED-USER-SUBR-UFN USER-SUBR-NUMBER EQ-TO-CAR
             EQ-TO-CADR)
        (PROP ARGNAMES USER-SUBR)
        

(* ;;; "SUBRCALL Vars & Functions")

        (EXPORT (VARS \INITSUBRS))
        (FUNCTIONS SUBRCALL)
        (OPTIMIZERS SUBRCALL)
        (FNS SUBRNUMBER)
        
        (* ;; "use this to make a subrs.h file for Maiko ")

        (FNS WRITECALLSUBRS FIX-SUBR-NAME)
        (PROP ARGNAMES SUBRCALL)
        (DECLARE%: DONTCOPY (RESOURCES UNIXSTRING))
        (INITRESOURCES UNIXSTRING)
        (FNS \MOREVMEMFILE \WRITEMAP \COPYSYS0SUBR \PUPLEVEL1STATE SHOWDISPLAY SETSCREENCOLOR 
             \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT
             DISKPARTITION \CHECKBCPLPASSWORD SUSPEND-LISP UNIX-USERNAME UNIX-FULLNAME UNIX-GETENV 
             UNIX-GETPARM)
        (IFPROP ARGNAMES SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH 
               \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD)
        (PROPS (LLSUBRS FILETYPE))))
(DECLARE%: EVAL@COMPILE DONTCOPY 

(ADDTOVAR DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS)
)



(* ;;; "MISCN  Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \MISCN-TABLE-LIST
       ((USER-SUBR 0 \USER-SUBR-UFN T)
        (CL:VALUES 1 CL::VALUES-UFN NIL)
        (CL:SXHASH 2 CL::SXHASH-UFN NIL)
        (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL)
        (STRINGHASHBITS 4 \STRINGHASHBITS-UFN NIL)
        (STRING-EQUAL-HASHBITS 5 \STRING-EQUAL-HASHBITS-UFN NIL)
        (CL:VALUES-LIST 6 CL::VALUES-LIST-UFN NIL)
        (LCFetchMethod 7 LCFetchMethod NIL)
        (LCFetchMethodOrHelp 8 NIL NIL)
        (LCFindVarIndex 9 NIL NIL)
        (LCGetIVValue 10 NIL NIL)
        (LCPutIVValue 11 NIL NIL)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO MISCN (NAME &REST ARGS)
   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
                                    (GENSYM]
        `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES
                                        ((OPCODES MISCN ,(MISCN-NUMBER NAME)
                                                ,(LENGTH ARGS))
                                         ,@ARGNAMES]
                ,@ARGS])

(DEFOPTIMIZER MISCN (NAME &REST ARGS)
                        `((OPCODES MISCN ,(MISCN-NUMBER NAME)
                                 ,(LENGTH ARGS))
                          ,@ARGS))
(DEFINEQ

(MISCN-NUMBER
(LAMBDA (NAME) (* ; "Edited  7-Nov-88 15:21 by krivacic") (CADR (OR (ASSOC NAME \MISCN-TABLE-LIST) (ERROR NAME " not a MISCN index"))))
)

(\MISCN.UFN
(LAMBDA (ALPHA-BETA) (* ; "Edited  8-Jun-89 16:57 by jds") (* ;; "The UFN for the MISCN opcode.") (DECLARE (GLOBALVARS \MISCN-TABLE)) (* ;; "Get the misc index & number of args from the code stream") (LET ((INDEX (LRSH ALPHA-BETA 8)) (ARG-COUNT (LOGAND ALPHA-BETA 255))) (* ;; "compute the position of the real IVARS on the stack.  Create a pointer to these args and pass it to the Handler routine.") (COND ((NOT (AND (BOUNDP (QUOTE \MISCN-TABLE)) \MISCN-TABLE)) (\INIT-MISCN-TABLE))) (LET* ((CALLER (\MYALINK)) (MY-BF (\GET-MY-BF)) (MY-IVAR (fetch (BF IVAR) of MY-BF)) (RESULT-IVAR (- MY-IVAR (LLSH ARG-COUNT 1))) (MY-PARMS-PTR (\VAG2 1 RESULT-IVAR)) (UFN-ENTRY (\ADDBASE \MISCN-TABLE (LLSH INDEX 1)))) (COND ((fetch (MISCN-UFN-ENTRY MISCN-MVS) OF UFN-ENTRY) (* ;; "This UFN can return Multiple values, so we need to preserve them.") (CL:UNWIND-PROTECT (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))) (T (* ;; "He said no MVs are possible, so don't even TRY to preserve them.  This is an expanded and cleaned up version of CL:UNWIND-PROTECT, so watch it!") (PROG1 (.UNWIND.PROTECT. (FUNCTION (LAMBDA NIL (replace (BF IVAR) of MY-BF with RESULT-IVAR))) (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR)) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR)))))))
)

(\UNDEFINED-MISCN-UFN
(LAMBDA (INDEX ARG-COUNT ARG-PTR) (* ; "Edited  3-Nov-88 15:56 by krivacic") (PRINTOUT T "index " INDEX ", arg count " ARG-COUNT T) (ERROR (CL:FORMAT T "Undefined MISCN[~d] with ~d args." INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR)))
)

(MISCN-COLLECT
(LAMBDA (ARG-COUNT ARG-PTR) (* ; "Edited  3-Nov-88 11:52 by krivacic") (FOR I FROM 0 TO (- ARG-COUNT 1) COLLECT (\GETBASEPTR ARG-PTR (LLSH I 1))))
)

(\GET-MY-BF
(LAMBDA NIL (* ; "Edited  3-Nov-88 11:08 by krivacic") (* ;; "Returns the stack index of the caller's BF.") (- (\MYALINK) 2))
)

(\INIT-MISCN-TABLE
(LAMBDA NIL (DECLARE (GLOBALVARS \MISCN-TABLE-LIST \MISCN-TABLE)) (* ; "Edited  7-Mar-89 09:43 by jds") (LET ((OP-NUMBER 36) (OP-LENGTH 3) BASE) (SETQ \MISCN-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-MISCN-UFN) 0)) (SETQ BASE (FETCH (ARRAYP BASE) OF \MISCN-TABLE)) (for MISCN-ENTRY in \MISCN-TABLE-LIST do (SETA \MISCN-TABLE (CADR MISCN-ENTRY) (CADDR MISCN-ENTRY)) (REPLACE (MISCN-UFN-ENTRY MISCN-MVS) OF (\ADDBASE2 BASE (FETCH (MISCN-UFN-SPEC INDEX) OF MISCN-ENTRY)) WITH (FETCH (MISCN-UFN-SPEC MVS) OF MISCN-ENTRY))) (SETQ \MISCN-TABLE BASE)))
)
)

(PUTPROPS MISCN ARGNAMES (NAME &REST ARGS))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD MISCN-UFN-SPEC (
                            (* ;; 
                "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.")

                            NAME                             (* ; 
                                                    "Name of the MISCN, for the MISCN macro's use.")
                            INDEX                            (* ; "Sub-opcode index.")
                            UFN-NAME                         (* ; "Name of the UFN")
                            MVS                              (* ; 
              "T if the UFN can returnmultiple values.  If this is NIL, MVs WILL NOT BE PRESERVED.")
                            ))

(BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG)
                                  (NIL BITS 3)
                                  (MISCN-UFN POINTER)))
)
)



(* ;;; " USER-SUBR Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN)
                            (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO USER-SUBR (USER-SUBR-NAME &REST ARGS)
   `(MISCN USER-SUBR ,(USER-SUBR-NUMBER USER-SUBR-NAME)
           ,@ARGS))

(CL:DEFUN ADD-USER-SUBR (USER-SUBR-NAME USER-SUBR-INDEX USER-SUBR-UFN)
   (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST))

   (* ;; "Make Sure \USER-SUBR-TABLE is made")

   (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE)
                     \USER-SUBR-TABLE))
       THEN (\INIT-USER-SUBR-TABLE))

   (* ;; "See if the Name is already defined")

   [AND (FASSOC USER-SUBR-NAME \USER-SUBR-LIST)
        (CL:CERROR "Delete old User-subr" "User-subr ~S already defined" USER-SUBR-NAME)
        (SETA \USER-SUBR-TABLE (CADR (FASSOC USER-SUBR-NAME \USER-SUBR-LIST))
              '\UNDEFINED-USER-SUBR-UFN)
        (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-NAME \USER-SUBR-LIST :TEST 'EQ-TO-CAR]

   (* ;; "See if the UFN is already defined")

   [AND (OR (NEQ (ELT \USER-SUBR-TABLE USER-SUBR-INDEX)
                 '\UNDEFINED-USER-SUBR-UFN)
            (CL:FIND USER-SUBR-INDEX \USER-SUBR-LIST :KEY #'CL:SECOND))
        (CL:CERROR "Delete old User-subr" " User-subr index ~d already defined" USER-SUBR-INDEX)
        (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-INDEX \USER-SUBR-LIST :TEST 'EQ-TO-CADR]
   (CL:PUSH (LIST USER-SUBR-NAME USER-SUBR-INDEX (OR USER-SUBR-UFN '\UNDEFINED-USER-SUBR-UFN))
          \USER-SUBR-LIST)
   (\INIT-USER-SUBR-TABLE))
(DEFINEQ

(\USER-SUBR-UFN
(LAMBDA (INDEX ARG-COUNT ARG-PTR) (DECLARE (GLOBALVARS \USER-SUBR-TABLE)) (* ; "Edited  4-Nov-88 18:43 by krivacic") (IF (NOT (AND (BOUNDP (QUOTE \USER-SUBR-TABLE)) \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (LET ((USER-SUBR-INDEX (\GETBASE ARG-PTR 1))) (* ;; "User SUBR ufn.  Index on the User subr indexes") (APPLY* (ELT \USER-SUBR-TABLE USER-SUBR-INDEX) USER-SUBR-INDEX (- ARG-COUNT 1) (\ADDBASE ARG-PTR 2))))
)

(\INIT-USER-SUBR-TABLE
(LAMBDA NIL (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST)) (* ; "Edited  4-Nov-88 18:58 by krivacic") (SETQ \USER-SUBR-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-USER-SUBR-UFN) 0)) (for SUBR-ENTRY in \USER-SUBR-LIST do (SETA \USER-SUBR-TABLE (CADR SUBR-ENTRY) (CADDR SUBR-ENTRY))))
)

(\UNDEFINED-USER-SUBR-UFN
(LAMBDA (USER-SUBR-INDEX ARG-COUNT ARG-PTR) (* ; "Edited  7-Nov-88 14:33 by krivacic") (* ;; "User SUBR ufn.  Index on the User subr indexes") (ERROR (CL:FORMAT NIL "Undefined USER-SUBR[~d] with ~d args." USER-SUBR-INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR)))
)

(USER-SUBR-NUMBER
(LAMBDA (NAME) (* ; "Edited  4-Nov-88 18:42 by krivacic") (CADR (OR (ASSOC NAME \USER-SUBR-LIST) (ERROR NAME " not a USER-SUBR index"))))
)

(EQ-TO-CAR
(LAMBDA (ITEM LIST) (EQ ITEM (CAR LIST))))

(EQ-TO-CADR
(LAMBDA (ITEM LIST) (EQ ITEM (CADR LIST))))
)

(PUTPROPS USER-SUBR ARGNAMES (USER-SUBR-NAME &REST ARGS))



(* ;;; "SUBRCALL Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \INITSUBRS
       ((BACKGROUNDSUBR 6)
        (CHECKBCPLPASSWORD 7)
        (DISKPARTITION 8)
        (DSPBOUT 9)
        (DSPRATE 10)
        (GATHERSTATS 11)
        (GETPACKETBUFFER 12)
        (LISPFINISH 13)
        (MOREVMEMFILE 14)
        (RAID 15)
        (READRAWPBI 16)
        (WRITERAWPBI 17)
        (SETSCREENCOLOR 18)
        (SHOWDISPLAY 19)
        (PUPLEVEL1STATE 20)
        (WRITESTATS 21)
        (CONTEXTSWITCH 22)
        (COPYSYS0SUBR 23)
        (WRITEMAP 24)
        (UFS-GETFILENAME 34)
        (UFS-DELETEFILE 35)
        (UFS-RENAMEFILE 36)
        (COM-READPAGES 37)
        (COM-WRITEPAGES 38)
        (COM-TRUNCATEFILE 39)
        (UFS-DIRECTORYNAMEP 41)
        (COM-GETFREEBLOCK 45)
        (SETUNIXTIME 48)
        (GETUNIXTIME 49)
        (COPYTIMESTATS 50)
        (UNIX-USERNAME 51)
        (UNIX-FULLNAME 52)
        (UNIX-GETENV 53)
        (UNIX-GETPARM 54)
        (CHECK-SUM 55)
        (ETHER-SUSPEND 56)
        (ETHER-RESUME 57)
        (ETHER-AVAILABLE 58)
        (ETHER-RESET 59)
        (ETHER-GET 60)
        (ETHER-SEND 61)
        (ETHER-SETFILTER 62)
        (ETHER-CHECK 63)
        (DSPCURSOR 64)
        (SETMOUSEXY 65)
        (DSP-VIDEOCOLOR 66)
        (DSP-SCREENWIDTH 67)
        (DSP-SCREENHEIGHT 68)
        (BITBLTSUB 69)
        (BLTCHAR 70)
        (TEDIT.BLTCHAR 71)
        (BITBLT.BITMAP 72)
        (BLTSHADE.BITMAP 73)
        (RS232C-CMD 74)
        (RS232C-READ-INIT 75)
        (RS232C-WRITE 76)
        (KEYBOARDBEEP 80)
        (KEYBOARDMAP 81)
        (KEYBOARDSTATE 82)
        (VMEMSAVE 89)
        (LISP-FINISH 90)
        (NEWPAGE 91)
        (DORECLAIM 92)
        (DUMMY-135Q 93)
        (NATIVE-MEMORY-REFERENCE 94)
        (OLD-COMPILE-LOAD-NATIVE 95)
        (DISABLEGC 96)
        (COM-SETFILEINFO 103)
        (COM-OPENFILE 104)
        (COM-CLOSEFILE 105)
        (DSK-GETFILENAME 106)
        (DSK-DELETEFILE 107)
        (DSK-RENAMEFILE 108)
        (COM-NEXT-FILE 110)
        (COM-FINISH-FINFO 111)
        (COM-GEN-FILES 112)
        (DSK-DIRECTORYNAMEP 113)
        (COM-GETFILEINFO 114)
        (COM-CHANGEDIR 116)
        (UNIX-HANDLECOMM 117)
        (RPC-CALL 119)
        (MESSAGE-READP 120)
        (MESSAGE-READ 121)
        (MONITOR-CONTROL 128)
        (GET-NATIVE-ADDR-FROM-LISP-PTR 131)
        (GET-LISP-PTR-FROM-NATIVE-ADDR 132)
        (LOAD-NATIVE-FILE 133)
        (SUSPEND-LISP 134)
        (NEW-BLTCHAR 135)
        (COLOR-INIT 136)
        (COLOR-SCREENMODE 137)
        (COLOR-MAP 138)
        (COLOR-BASE 139)
        (C-SlowBltChar 140)
        (UNCOLORIZE-BITMAP 141)
        (COLORIZE-BITMAP 142)
        (COLOR-8BPPDRAWLINE 143)
        (TCP-OP 144)
        (WITH-SYMBOL 145)
        (CAUSE-INTERRUPT 146)
        (OPEN-SOCKET 160)
        (CLOSE-SOCKET 161)
        (READ-SOCKET 162)
        (WRITE-SOCKET 163)
        (CALL-C-FUNCTION 167)
        (DLD-LINK 168)
        (DLD-UNLINK-BY-FILE 169)
        (DLD-UNLINK-BY-SYMBOL 170)
        (DLD-GET-SYMBOL 171)
        (DLD-GET-FUNC 172)
        (DLD-FUNCTION-EXECUTABLE-P 173)
        (DLD-LIST-UNDEFINED-SYMBOLS 174)
        (C-MALLOC 175)
        (C-FREE 176)
        (C-PUTBASEBYTE 177)
        (C-GETBASEBYTE 178)
        (CHAR-OPENFILE 200)
        (CHAR-BIN 201)
        (CHAR-BOUT 202)
        (CHAR-IOCTL 203)
        (CHAR-CLOSEFILE 204)
        (CHAR-EOFP 205)
        (CHAR-READP 206)
        (CHAR-BINS 207)
        (CHAR-BOUTS 208)
        (CHAR-FILLBUFFER 209)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO SUBRCALL (NAME &REST ARGS)
   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
                                    (GENSYM]
        `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES
                                        ((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
                                                ,(LENGTH ARGS))
                                         ,@ARGNAMES]
                ,@ARGS])

(DEFOPTIMIZER SUBRCALL (NAME &REST ARGS)
                           `((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
                                    ,(LENGTH ARGS))
                             ,@ARGS))
(DEFINEQ

(SUBRNUMBER
  [LAMBDA (NAME)                                         (* ; "Edited  5-Feb-92 16:49 by jds")

    (* ;; "Given a SUBR's NAME or number, return the corresponding subr number.")

    (LET (NUMBER)
         (COND
            ((FIXP NAME)
             (CL:WARN "SUBR name (~d) is a number; should be abstracted." NAME)
             NAME)
            ((CADR (ASSOC NAME \INITSUBRS)))
            ([SETQ NUMBER (CADR (CL:ASSOC NAME \INITSUBRS :TEST (FUNCTION STRING.EQUAL]
             (CL:WARN "SUBR name ~s is in wrong package.  Using ~d as subr number." NAME NUMBER))
            (T (ERROR NAME " not a SUBR"])
)



(* ;; "use this to make a subrs.h file for Maiko ")

(DEFINEQ

(WRITECALLSUBRS
(LAMBDA NIL (* ; "Edited  6-Nov-89 15:39 by jds") (CL:WITH-OPEN-FILE (*STANDARD-OUTPUT* "subrs.h" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (CL:FORMAT T "/* This file written from LLSUBRS on ~A                      */~&" (DATE)) (CL:FORMAT T "/* Do not edit this file! Instead, edit the list \initsubrs */~&") (CL:FORMAT T "/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to  */~&") (CL:FORMAT T "/* generate a new version.                                   */~&") (for X in \INITSUBRS do (CL:FORMAT T "#define sb_~A	0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* MISCN opcodes */~&") (for X in \MISCN-TABLE-LIST do (CL:FORMAT T "#define miscn_~A	0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* Assigned USER SUBR numbers */~&") (for X in \USER-SUBR-LIST do (CL:FORMAT T "#define user_subr_~A	0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X)))))
)

(FIX-SUBR-NAME
(LAMBDA (NAME) (* ; "Edited 13-Feb-89 16:17 by jds") (* ;; "Fix up a SUBR name for use as a symbol in the C code, by:") (* ;; "Converting all -'s to _'s") (* ;; "Converting all .'s to _'s") (* ;; "Removing all \'s.") (* ;; "This allows us to use fairly normal Lisp symbols for SUBR names (like \TEDIT.BLTCHAR), while having them translate pleasantly.") (CONCATCODES (DREMOVE (CHARCODE \) (SUBST (CHARCODE _) (CHARCODE %.) (SUBST (CHARCODE _) (CHARCODE -) (CHCON NAME))))))
)
)

(PUTPROPS SUBRCALL ARGNAMES (NAME &REST ARGS))
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTDEF 'UNIXSTRING 'RESOURCES '(NEW (ALLOCSTRING 512]
)
)

(/SETTOPVAL '\UNIXSTRING.GLOBALRESOURCE NIL)
(DEFINEQ

(\MOREVMEMFILE
(LAMBDA (FILEPAGE) (* ; "Edited 27-Apr-88 13:36 by MASINTER") (SUBRCALL MOREVMEMFILE FILEPAGE)))

(\WRITEMAP
(LAMBDA (VP RP FLAGS) (* ; "Edited 27-Apr-88 13:37 by MASINTER") (SUBRCALL WRITEMAP VP RP FLAGS)))

(\COPYSYS0SUBR
(LAMBDA (FID) (* ; "Edited 20-Apr-88 12:36 by MASINTER") (SUBRCALL COPYSYS0SUBR FID)))

(\PUPLEVEL1STATE
(LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL PUPLEVEL1STATE FLG)))

(SHOWDISPLAY
(LAMBDA (BASE RASTERWIDTH) (* ; "Edited 27-Apr-88 13:40 by MASINTER") (* ;; "comments are done with semicolons one comment is at the right margin, it automatically do you type ") (SUBRCALL SHOWDISPLAY BASE RASTERWIDTH))
)

(SETSCREENCOLOR
(LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL SETSCREENCOLOR FLG)))

(\WRITERAWPBI
(LAMBDA (PBI) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL WRITERAWPBI PBI)))

(\READRAWPBI
(LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL READRAWPBI)))

(RAID
(LAMBDA (MESS1 MESS2 FLG) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL RAID MESS1 MESS2 FLG)))

(\LISPFINISH
(LAMBDA (DUMMY) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL LISPFINISH DUMMY)))

(\GETPACKETBUFFER
(LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GETPACKETBUFFER)))

(\GATHERSTATS
(LAMBDA (FID) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GATHERSTATS FID)))

(\DSPRATE
(LAMBDA (AC0 AC1 AC2) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPRATE AC0 AC1 AC2))
)

(DSPBOUT
(LAMBDA (CHARCODE) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPBOUT CHARCODE)))

(DISKPARTITION
(LAMBDA NIL (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SELECTQ (MACHINETYPE) ((DORADO DOLPHIN) (SUBRCALL DISKPARTITION)) ((DANDELION DOVE) (\DFSCurrentVolume)) NIL))
)

(\CHECKBCPLPASSWORD
(LAMBDA (USER PASSWORD) (* ; "Edited 14-Jun-88 13:33 by drc:") (SUBRCALL CHECKBCPLPASSWORD USER PASSWORD))
)

(SUSPEND-LISP
(LAMBDA NIL (* ; "Edited 20-Jun-88 15:24 by greep") (if (EQ (MACHINETYPE) (QUOTE MAIKO)) then (SUBRCALL SUSPEND-LISP) T else NIL))
)

(UNIX-USERNAME
(LAMBDA NIL (* ; "Edited  1-Aug-88 23:22 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING)))))))
)

(UNIX-FULLNAME
(LAMBDA NIL (* ; "Edited 18-Jul-88 03:47 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING)))))))
)

(UNIX-GETENV
(LAMBDA (NAME) (* ; "Edited  1-Aug-88 23:13 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-GETENV (MKSTRING NAME) UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING)))))))
)

(UNIX-GETPARM
(LAMBDA (NAME) (* ; "Edited 27-Feb-91 17:11 by nm") (* ;; "Read information from the C emulator.  Usually gets info about configuration of the machine we're running on.") (* ;; "Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.") (* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.") (if (EQ \MACHINETYPE \MAIKO) then (LET (LEN) (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME) UNIXSTRING)) (COND ((SMALLP LEN) (if (> LEN 0) then (CONCAT (SUBSTRING UNIXSTRING 1 LEN)))) (LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING))))))))))
)
)

(PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH))

(PUTPROPS SETSCREENCOLOR ARGNAMES (FLG))

(PUTPROPS \WRITERAWPBI ARGNAMES (PBI))

(PUTPROPS \READRAWPBI ARGNAMES NIL)

(PUTPROPS RAID ARGNAMES (MESS1 MESS2 FLG))

(PUTPROPS \LISPFINISH ARGNAMES (DUMMY))

(PUTPROPS \GETPACKETBUFFER ARGNAMES NIL)

(PUTPROPS \GATHERSTATS ARGNAMES (FID))

(PUTPROPS \DSPRATE ARGNAMES (AC0 AC1 AC2))

(PUTPROPS DSPBOUT ARGNAMES (CHARCODE))

(PUTPROPS DISKPARTITION ARGNAMES NIL)

(PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR))

(PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE)
(PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3665 6454 (MISCN-NUMBER 3675 . 3830) (\MISCN.UFN 3832 . 5287) (\UNDEFINED-MISCN-UFN 
5289 . 5557) (MISCN-COLLECT 5559 . 5726) (\GET-MY-BF 5728 . 5871) (\INIT-MISCN-TABLE 5873 . 6452)) (
9128 10493 (\USER-SUBR-UFN 9138 . 9578) (\INIT-USER-SUBR-TABLE 9580 . 9907) (\UNDEFINED-USER-SUBR-UFN 
9909 . 10208) (USER-SUBR-NUMBER 10210 . 10371) (EQ-TO-CAR 10373 . 10430) (EQ-TO-CADR 10432 . 10491)) (
14756 15405 (SUBRNUMBER 14766 . 15403)) (15466 16873 (WRITECALLSUBRS 15476 . 16376) (FIX-SUBR-NAME 
16378 . 16871)) (17082 20697 (\MOREVMEMFILE 17092 . 17207) (\WRITEMAP 17209 . 17322) (\COPYSYS0SUBR 
17324 . 17429) (\PUPLEVEL1STATE 17431 . 17540) (SHOWDISPLAY 17542 . 17780) (SETSCREENCOLOR 17782 . 
17890) (\WRITERAWPBI 17892 . 17995) (\READRAWPBI 17997 . 18092) (RAID 18094 . 18206) (\LISPFINISH 
18208 . 18313) (\GETPACKETBUFFER 18315 . 18420) (\GATHERSTATS 18422 . 18525) (\DSPRATE 18527 . 18682) 
(DSPBOUT 18684 . 18788) (DISKPARTITION 18790 . 18977) (\CHECKBCPLPASSWORD 18979 . 19111) (SUSPEND-LISP
 19113 . 19263) (UNIX-USERNAME 19265 . 19515) (UNIX-FULLNAME 19517 . 19768) (UNIX-GETENV 19770 . 20035
) (UNIX-GETPARM 20037 . 20695)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "21-Feb-2021 21:20:11" {DSK}<home>larry>medley>sources>LLSUBRS.;2 21799  

      changes to%:  (FNS UNIX-GETENV)

      previous date%: "17-Dec-92 14:28:41" {DSK}<home>larry>medley>sources>LLSUBRS.;1)


(* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1988, 1989, 1990, 1991, 1992, 2021 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT LLSUBRSCOMS)

(RPAQQ LLSUBRSCOMS
       ((DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME 
                                                         WRITECALLSUBRS)))
        

(* ;;; "MISCN  Vars & Functions")

        (EXPORT (VARS \MISCN-TABLE-LIST))
        (FUNCTIONS MISCN)
        (OPTIMIZERS MISCN)
        (FNS MISCN-NUMBER \MISCN.UFN \UNDEFINED-MISCN-UFN MISCN-COLLECT \GET-MY-BF \INIT-MISCN-TABLE)
        (PROP ARGNAMES MISCN)
        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MISCN-UFN-SPEC MISCN-UFN-ENTRY))
        

(* ;;; " USER-SUBR Vars & Functions")

        (EXPORT (VARS \USER-SUBR-LIST))
        (FUNCTIONS USER-SUBR ADD-USER-SUBR)
        (FNS \USER-SUBR-UFN \INIT-USER-SUBR-TABLE \UNDEFINED-USER-SUBR-UFN USER-SUBR-NUMBER EQ-TO-CAR
             EQ-TO-CADR)
        (PROP ARGNAMES USER-SUBR)
        

(* ;;; "SUBRCALL Vars & Functions")

        (EXPORT (VARS \INITSUBRS))
        (FUNCTIONS SUBRCALL)
        (OPTIMIZERS SUBRCALL)
        (FNS SUBRNUMBER)
        
        (* ;; "use this to make a subrs.h file for Maiko ")

        (FNS WRITECALLSUBRS FIX-SUBR-NAME)
        (PROP ARGNAMES SUBRCALL)
        (DECLARE%: DONTCOPY (RESOURCES UNIXSTRING))
        (INITRESOURCES UNIXSTRING)
        (FNS \MOREVMEMFILE \WRITEMAP \COPYSYS0SUBR \PUPLEVEL1STATE SHOWDISPLAY SETSCREENCOLOR 
             \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT
             DISKPARTITION \CHECKBCPLPASSWORD SUSPEND-LISP UNIX-USERNAME UNIX-FULLNAME UNIX-GETENV 
             UNIX-GETPARM)
        (IFPROP ARGNAMES SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH 
               \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD)
        (PROPS (LLSUBRS FILETYPE))))
(DECLARE%: EVAL@COMPILE DONTCOPY 

(ADDTOVAR DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS)
)



(* ;;; "MISCN  Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \MISCN-TABLE-LIST
       ((USER-SUBR 0 \USER-SUBR-UFN T)
        (CL:VALUES 1 CL::VALUES-UFN NIL)
        (CL:SXHASH 2 CL::SXHASH-UFN NIL)
        (CL::EQLHASHBITSFN 3 CL::EQLHASHBITSFN-UFN NIL)
        (STRINGHASHBITS 4 \STRINGHASHBITS-UFN NIL)
        (STRING-EQUAL-HASHBITS 5 \STRING-EQUAL-HASHBITS-UFN NIL)
        (CL:VALUES-LIST 6 CL::VALUES-LIST-UFN NIL)
        (LCFetchMethod 7 LCFetchMethod NIL)
        (LCFetchMethodOrHelp 8 NIL NIL)
        (LCFindVarIndex 9 NIL NIL)
        (LCGetIVValue 10 NIL NIL)
        (LCPutIVValue 11 NIL NIL)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO MISCN (NAME &REST ARGS)
   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
                                    (GENSYM]
        `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES
                                        ((OPCODES MISCN ,(MISCN-NUMBER NAME)
                                                ,(LENGTH ARGS))
                                         ,@ARGNAMES]
                ,@ARGS])

(DEFOPTIMIZER MISCN (NAME &REST ARGS)
                        `((OPCODES MISCN ,(MISCN-NUMBER NAME)
                                 ,(LENGTH ARGS))
                          ,@ARGS))
(DEFINEQ

(MISCN-NUMBER
(LAMBDA (NAME) (* ; "Edited  7-Nov-88 15:21 by krivacic") (CADR (OR (ASSOC NAME \MISCN-TABLE-LIST) (ERROR NAME " not a MISCN index"))))
)

(\MISCN.UFN
(LAMBDA (ALPHA-BETA) (* ; "Edited  8-Jun-89 16:57 by jds") (* ;; "The UFN for the MISCN opcode.") (DECLARE (GLOBALVARS \MISCN-TABLE)) (* ;; "Get the misc index & number of args from the code stream") (LET ((INDEX (LRSH ALPHA-BETA 8)) (ARG-COUNT (LOGAND ALPHA-BETA 255))) (* ;; "compute the position of the real IVARS on the stack.  Create a pointer to these args and pass it to the Handler routine.") (COND ((NOT (AND (BOUNDP (QUOTE \MISCN-TABLE)) \MISCN-TABLE)) (\INIT-MISCN-TABLE))) (LET* ((CALLER (\MYALINK)) (MY-BF (\GET-MY-BF)) (MY-IVAR (fetch (BF IVAR) of MY-BF)) (RESULT-IVAR (- MY-IVAR (LLSH ARG-COUNT 1))) (MY-PARMS-PTR (\VAG2 1 RESULT-IVAR)) (UFN-ENTRY (\ADDBASE \MISCN-TABLE (LLSH INDEX 1)))) (COND ((fetch (MISCN-UFN-ENTRY MISCN-MVS) OF UFN-ENTRY) (* ;; "This UFN can return Multiple values, so we need to preserve them.") (CL:UNWIND-PROTECT (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))) (T (* ;; "He said no MVs are possible, so don't even TRY to preserve them.  This is an expanded and cleaned up version of CL:UNWIND-PROTECT, so watch it!") (PROG1 (.UNWIND.PROTECT. (FUNCTION (LAMBDA NIL (replace (BF IVAR) of MY-BF with RESULT-IVAR))) (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR)) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR)))))))
)

(\UNDEFINED-MISCN-UFN
(LAMBDA (INDEX ARG-COUNT ARG-PTR) (* ; "Edited  3-Nov-88 15:56 by krivacic") (PRINTOUT T "index " INDEX ", arg count " ARG-COUNT T) (ERROR (CL:FORMAT T "Undefined MISCN[~d] with ~d args." INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR)))
)

(MISCN-COLLECT
(LAMBDA (ARG-COUNT ARG-PTR) (* ; "Edited  3-Nov-88 11:52 by krivacic") (FOR I FROM 0 TO (- ARG-COUNT 1) COLLECT (\GETBASEPTR ARG-PTR (LLSH I 1))))
)

(\GET-MY-BF
(LAMBDA NIL (* ; "Edited  3-Nov-88 11:08 by krivacic") (* ;; "Returns the stack index of the caller's BF.") (- (\MYALINK) 2))
)

(\INIT-MISCN-TABLE
(LAMBDA NIL (DECLARE (GLOBALVARS \MISCN-TABLE-LIST \MISCN-TABLE)) (* ; "Edited  7-Mar-89 09:43 by jds") (LET ((OP-NUMBER 36) (OP-LENGTH 3) BASE) (SETQ \MISCN-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-MISCN-UFN) 0)) (SETQ BASE (FETCH (ARRAYP BASE) OF \MISCN-TABLE)) (for MISCN-ENTRY in \MISCN-TABLE-LIST do (SETA \MISCN-TABLE (CADR MISCN-ENTRY) (CADDR MISCN-ENTRY)) (REPLACE (MISCN-UFN-ENTRY MISCN-MVS) OF (\ADDBASE2 BASE (FETCH (MISCN-UFN-SPEC INDEX) OF MISCN-ENTRY)) WITH (FETCH (MISCN-UFN-SPEC MVS) OF MISCN-ENTRY))) (SETQ \MISCN-TABLE BASE)))
)
)

(PUTPROPS MISCN ARGNAMES (NAME &REST ARGS))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD MISCN-UFN-SPEC (
                            (* ;; 
                "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.")

                            NAME                             (* ; 
                                                    "Name of the MISCN, for the MISCN macro's use.")
                            INDEX                            (* ; "Sub-opcode index.")
                            UFN-NAME                         (* ; "Name of the UFN")
                            MVS                              (* ; 
              "T if the UFN can returnmultiple values.  If this is NIL, MVs WILL NOT BE PRESERVED.")
                            ))

(BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG)
                                  (NIL BITS 3)
                                  (MISCN-UFN POINTER)))
)
)



(* ;;; " USER-SUBR Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN)
                            (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO USER-SUBR (USER-SUBR-NAME &REST ARGS)
   `(MISCN USER-SUBR ,(USER-SUBR-NUMBER USER-SUBR-NAME)
           ,@ARGS))

(CL:DEFUN ADD-USER-SUBR (USER-SUBR-NAME USER-SUBR-INDEX USER-SUBR-UFN)
   (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST))

   (* ;; "Make Sure \USER-SUBR-TABLE is made")

   (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE)
                     \USER-SUBR-TABLE))
       THEN (\INIT-USER-SUBR-TABLE))

   (* ;; "See if the Name is already defined")

   [AND (FASSOC USER-SUBR-NAME \USER-SUBR-LIST)
        (CL:CERROR "Delete old User-subr" "User-subr ~S already defined" USER-SUBR-NAME)
        (SETA \USER-SUBR-TABLE (CADR (FASSOC USER-SUBR-NAME \USER-SUBR-LIST))
              '\UNDEFINED-USER-SUBR-UFN)
        (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-NAME \USER-SUBR-LIST :TEST 'EQ-TO-CAR]

   (* ;; "See if the UFN is already defined")

   [AND (OR (NEQ (ELT \USER-SUBR-TABLE USER-SUBR-INDEX)
                 '\UNDEFINED-USER-SUBR-UFN)
            (CL:FIND USER-SUBR-INDEX \USER-SUBR-LIST :KEY #'CL:SECOND))
        (CL:CERROR "Delete old User-subr" " User-subr index ~d already defined" USER-SUBR-INDEX)
        (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-INDEX \USER-SUBR-LIST :TEST 'EQ-TO-CADR]
   (CL:PUSH (LIST USER-SUBR-NAME USER-SUBR-INDEX (OR USER-SUBR-UFN '\UNDEFINED-USER-SUBR-UFN))
          \USER-SUBR-LIST)
   (\INIT-USER-SUBR-TABLE))
(DEFINEQ

(\USER-SUBR-UFN
(LAMBDA (INDEX ARG-COUNT ARG-PTR) (DECLARE (GLOBALVARS \USER-SUBR-TABLE)) (* ; "Edited  4-Nov-88 18:43 by krivacic") (IF (NOT (AND (BOUNDP (QUOTE \USER-SUBR-TABLE)) \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (LET ((USER-SUBR-INDEX (\GETBASE ARG-PTR 1))) (* ;; "User SUBR ufn.  Index on the User subr indexes") (APPLY* (ELT \USER-SUBR-TABLE USER-SUBR-INDEX) USER-SUBR-INDEX (- ARG-COUNT 1) (\ADDBASE ARG-PTR 2))))
)

(\INIT-USER-SUBR-TABLE
(LAMBDA NIL (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST)) (* ; "Edited  4-Nov-88 18:58 by krivacic") (SETQ \USER-SUBR-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-USER-SUBR-UFN) 0)) (for SUBR-ENTRY in \USER-SUBR-LIST do (SETA \USER-SUBR-TABLE (CADR SUBR-ENTRY) (CADDR SUBR-ENTRY))))
)

(\UNDEFINED-USER-SUBR-UFN
(LAMBDA (USER-SUBR-INDEX ARG-COUNT ARG-PTR) (* ; "Edited  7-Nov-88 14:33 by krivacic") (* ;; "User SUBR ufn.  Index on the User subr indexes") (ERROR (CL:FORMAT NIL "Undefined USER-SUBR[~d] with ~d args." USER-SUBR-INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR)))
)

(USER-SUBR-NUMBER
(LAMBDA (NAME) (* ; "Edited  4-Nov-88 18:42 by krivacic") (CADR (OR (ASSOC NAME \USER-SUBR-LIST) (ERROR NAME " not a USER-SUBR index"))))
)

(EQ-TO-CAR
(LAMBDA (ITEM LIST) (EQ ITEM (CAR LIST))))

(EQ-TO-CADR
(LAMBDA (ITEM LIST) (EQ ITEM (CADR LIST))))
)

(PUTPROPS USER-SUBR ARGNAMES (USER-SUBR-NAME &REST ARGS))



(* ;;; "SUBRCALL Vars & Functions")

(* "FOLLOWING DEFINITIONS EXPORTED")
(RPAQQ \INITSUBRS
       ((BACKGROUNDSUBR 6)
        (CHECKBCPLPASSWORD 7)
        (DISKPARTITION 8)
        (DSPBOUT 9)
        (DSPRATE 10)
        (GATHERSTATS 11)
        (GETPACKETBUFFER 12)
        (LISPFINISH 13)
        (MOREVMEMFILE 14)
        (RAID 15)
        (READRAWPBI 16)
        (WRITERAWPBI 17)
        (SETSCREENCOLOR 18)
        (SHOWDISPLAY 19)
        (PUPLEVEL1STATE 20)
        (WRITESTATS 21)
        (CONTEXTSWITCH 22)
        (COPYSYS0SUBR 23)
        (WRITEMAP 24)
        (UFS-GETFILENAME 34)
        (UFS-DELETEFILE 35)
        (UFS-RENAMEFILE 36)
        (COM-READPAGES 37)
        (COM-WRITEPAGES 38)
        (COM-TRUNCATEFILE 39)
        (UFS-DIRECTORYNAMEP 41)
        (COM-GETFREEBLOCK 45)
        (SETUNIXTIME 48)
        (GETUNIXTIME 49)
        (COPYTIMESTATS 50)
        (UNIX-USERNAME 51)
        (UNIX-FULLNAME 52)
        (UNIX-GETENV 53)
        (UNIX-GETPARM 54)
        (CHECK-SUM 55)
        (ETHER-SUSPEND 56)
        (ETHER-RESUME 57)
        (ETHER-AVAILABLE 58)
        (ETHER-RESET 59)
        (ETHER-GET 60)
        (ETHER-SEND 61)
        (ETHER-SETFILTER 62)
        (ETHER-CHECK 63)
        (DSPCURSOR 64)
        (SETMOUSEXY 65)
        (DSP-VIDEOCOLOR 66)
        (DSP-SCREENWIDTH 67)
        (DSP-SCREENHEIGHT 68)
        (BITBLTSUB 69)
        (BLTCHAR 70)
        (TEDIT.BLTCHAR 71)
        (BITBLT.BITMAP 72)
        (BLTSHADE.BITMAP 73)
        (RS232C-CMD 74)
        (RS232C-READ-INIT 75)
        (RS232C-WRITE 76)
        (KEYBOARDBEEP 80)
        (KEYBOARDMAP 81)
        (KEYBOARDSTATE 82)
        (VMEMSAVE 89)
        (LISP-FINISH 90)
        (NEWPAGE 91)
        (DORECLAIM 92)
        (DUMMY-135Q 93)
        (NATIVE-MEMORY-REFERENCE 94)
        (OLD-COMPILE-LOAD-NATIVE 95)
        (DISABLEGC 96)
        (COM-SETFILEINFO 103)
        (COM-OPENFILE 104)
        (COM-CLOSEFILE 105)
        (DSK-GETFILENAME 106)
        (DSK-DELETEFILE 107)
        (DSK-RENAMEFILE 108)
        (COM-NEXT-FILE 110)
        (COM-FINISH-FINFO 111)
        (COM-GEN-FILES 112)
        (DSK-DIRECTORYNAMEP 113)
        (COM-GETFILEINFO 114)
        (COM-CHANGEDIR 116)
        (UNIX-HANDLECOMM 117)
        (RPC-CALL 119)
        (MESSAGE-READP 120)
        (MESSAGE-READ 121)
        (MONITOR-CONTROL 128)
        (GET-NATIVE-ADDR-FROM-LISP-PTR 131)
        (GET-LISP-PTR-FROM-NATIVE-ADDR 132)
        (LOAD-NATIVE-FILE 133)
        (SUSPEND-LISP 134)
        (NEW-BLTCHAR 135)
        (COLOR-INIT 136)
        (COLOR-SCREENMODE 137)
        (COLOR-MAP 138)
        (COLOR-BASE 139)
        (C-SlowBltChar 140)
        (UNCOLORIZE-BITMAP 141)
        (COLORIZE-BITMAP 142)
        (COLOR-8BPPDRAWLINE 143)
        (TCP-OP 144)
        (WITH-SYMBOL 145)
        (CAUSE-INTERRUPT 146)
        (OPEN-SOCKET 160)
        (CLOSE-SOCKET 161)
        (READ-SOCKET 162)
        (WRITE-SOCKET 163)
        (CALL-C-FUNCTION 167)
        (DLD-LINK 168)
        (DLD-UNLINK-BY-FILE 169)
        (DLD-UNLINK-BY-SYMBOL 170)
        (DLD-GET-SYMBOL 171)
        (DLD-GET-FUNC 172)
        (DLD-FUNCTION-EXECUTABLE-P 173)
        (DLD-LIST-UNDEFINED-SYMBOLS 174)
        (C-MALLOC 175)
        (C-FREE 176)
        (C-PUTBASEBYTE 177)
        (C-GETBASEBYTE 178)
        (CHAR-OPENFILE 200)
        (CHAR-BIN 201)
        (CHAR-BOUT 202)
        (CHAR-IOCTL 203)
        (CHAR-CLOSEFILE 204)
        (CHAR-EOFP 205)
        (CHAR-READP 206)
        (CHAR-BINS 207)
        (CHAR-BOUTS 208)
        (CHAR-FILLBUFFER 209)))

(* "END EXPORTED DEFINITIONS")


(DEFMACRO SUBRCALL (NAME &REST ARGS)
   [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X)
                                    (GENSYM]
        `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES
                                        ((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
                                                ,(LENGTH ARGS))
                                         ,@ARGNAMES]
                ,@ARGS])

(DEFOPTIMIZER SUBRCALL (NAME &REST ARGS)
                           `((OPCODES SUBRCALL ,(SUBRNUMBER NAME)
                                    ,(LENGTH ARGS))
                             ,@ARGS))
(DEFINEQ

(SUBRNUMBER
  [LAMBDA (NAME)                                         (* ; "Edited  5-Feb-92 16:49 by jds")

    (* ;; "Given a SUBR's NAME or number, return the corresponding subr number.")

    (LET (NUMBER)
         (COND
            ((FIXP NAME)
             (CL:WARN "SUBR name (~d) is a number; should be abstracted." NAME)
             NAME)
            ((CADR (ASSOC NAME \INITSUBRS)))
            ([SETQ NUMBER (CADR (CL:ASSOC NAME \INITSUBRS :TEST (FUNCTION STRING.EQUAL]
             (CL:WARN "SUBR name ~s is in wrong package.  Using ~d as subr number." NAME NUMBER))
            (T (ERROR NAME " not a SUBR"])
)



(* ;; "use this to make a subrs.h file for Maiko ")

(DEFINEQ

(WRITECALLSUBRS
(LAMBDA NIL (* ; "Edited  6-Nov-89 15:39 by jds") (CL:WITH-OPEN-FILE (*STANDARD-OUTPUT* "subrs.h" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (CL:FORMAT T "/* This file written from LLSUBRS on ~A                      */~&" (DATE)) (CL:FORMAT T "/* Do not edit this file! Instead, edit the list \initsubrs */~&") (CL:FORMAT T "/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to  */~&") (CL:FORMAT T "/* generate a new version.                                   */~&") (for X in \INITSUBRS do (CL:FORMAT T "#define sb_~A	0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* MISCN opcodes */~&") (for X in \MISCN-TABLE-LIST do (CL:FORMAT T "#define miscn_~A	0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* Assigned USER SUBR numbers */~&") (for X in \USER-SUBR-LIST do (CL:FORMAT T "#define user_subr_~A	0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X)))))
)

(FIX-SUBR-NAME
(LAMBDA (NAME) (* ; "Edited 13-Feb-89 16:17 by jds") (* ;; "Fix up a SUBR name for use as a symbol in the C code, by:") (* ;; "Converting all -'s to _'s") (* ;; "Converting all .'s to _'s") (* ;; "Removing all \'s.") (* ;; "This allows us to use fairly normal Lisp symbols for SUBR names (like \TEDIT.BLTCHAR), while having them translate pleasantly.") (CONCATCODES (DREMOVE (CHARCODE \) (SUBST (CHARCODE _) (CHARCODE %.) (SUBST (CHARCODE _) (CHARCODE -) (CHCON NAME))))))
)
)

(PUTPROPS SUBRCALL ARGNAMES (NAME &REST ARGS))
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTDEF 'UNIXSTRING 'RESOURCES '(NEW (ALLOCSTRING 512]
)
)

(/SETTOPVAL '\UNIXSTRING.GLOBALRESOURCE NIL)
(DEFINEQ

(\MOREVMEMFILE
(LAMBDA (FILEPAGE) (* ; "Edited 27-Apr-88 13:36 by MASINTER") (SUBRCALL MOREVMEMFILE FILEPAGE)))

(\WRITEMAP
(LAMBDA (VP RP FLAGS) (* ; "Edited 27-Apr-88 13:37 by MASINTER") (SUBRCALL WRITEMAP VP RP FLAGS)))

(\COPYSYS0SUBR
(LAMBDA (FID) (* ; "Edited 20-Apr-88 12:36 by MASINTER") (SUBRCALL COPYSYS0SUBR FID)))

(\PUPLEVEL1STATE
(LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL PUPLEVEL1STATE FLG)))

(SHOWDISPLAY
(LAMBDA (BASE RASTERWIDTH) (* ; "Edited 27-Apr-88 13:40 by MASINTER") (* ;; "comments are done with semicolons one comment is at the right margin, it automatically do you type ") (SUBRCALL SHOWDISPLAY BASE RASTERWIDTH))
)

(SETSCREENCOLOR
(LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL SETSCREENCOLOR FLG)))

(\WRITERAWPBI
(LAMBDA (PBI) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL WRITERAWPBI PBI)))

(\READRAWPBI
(LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL READRAWPBI)))

(RAID
(LAMBDA (MESS1 MESS2 FLG) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL RAID MESS1 MESS2 FLG)))

(\LISPFINISH
(LAMBDA (DUMMY) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL LISPFINISH DUMMY)))

(\GETPACKETBUFFER
(LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GETPACKETBUFFER)))

(\GATHERSTATS
(LAMBDA (FID) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GATHERSTATS FID)))

(\DSPRATE
(LAMBDA (AC0 AC1 AC2) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPRATE AC0 AC1 AC2))
)

(DSPBOUT
(LAMBDA (CHARCODE) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPBOUT CHARCODE)))

(DISKPARTITION
(LAMBDA NIL (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SELECTQ (MACHINETYPE) ((DORADO DOLPHIN) (SUBRCALL DISKPARTITION)) ((DANDELION DOVE) (\DFSCurrentVolume)) NIL))
)

(\CHECKBCPLPASSWORD
(LAMBDA (USER PASSWORD) (* ; "Edited 14-Jun-88 13:33 by drc:") (SUBRCALL CHECKBCPLPASSWORD USER PASSWORD))
)

(SUSPEND-LISP
(LAMBDA NIL (* ; "Edited 20-Jun-88 15:24 by greep") (if (EQ (MACHINETYPE) (QUOTE MAIKO)) then (SUBRCALL SUSPEND-LISP) T else NIL))
)

(UNIX-USERNAME
(LAMBDA NIL (* ; "Edited  1-Aug-88 23:22 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING)))))))
)

(UNIX-FULLNAME
(LAMBDA NIL (* ; "Edited 18-Jul-88 03:47 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING)))))))
)

(UNIX-GETENV
  [LAMBDA (NAME)                                       (* ; "Edited 21-Feb-2021 21:09 by larry")
    (WITH-RESOURCES
     UNIXSTRING
     (LET ((X UNIXSTRING))
          (if (SUBRCALL UNIX-GETENV (MKSTRING NAME)
                         X)
              then (CONCAT (SUBSTRING X 1 (for I from 1
                                                 do (if (FMEMB (NTHCHARCODE X I)
                                                                       '(0 NIL))
                                                            then (RETURN (SUB1 I])

(UNIX-GETPARM
(LAMBDA (NAME) (* ; "Edited 27-Feb-91 17:11 by nm") (* ;; "Read information from the C emulator.  Usually gets info about configuration of the machine we're running on.") (* ;; "Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.") (* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.") (if (EQ \MACHINETYPE \MAIKO) then (LET (LEN) (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME) UNIXSTRING)) (COND ((SMALLP LEN) (if (> LEN 0) then (CONCAT (SUBSTRING UNIXSTRING 1 LEN)))) (LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING))))))))))
)
)

(PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH))

(PUTPROPS SETSCREENCOLOR ARGNAMES (FLG))

(PUTPROPS \WRITERAWPBI ARGNAMES (PBI))

(PUTPROPS \READRAWPBI ARGNAMES NIL)

(PUTPROPS RAID ARGNAMES (MESS1 MESS2 FLG))

(PUTPROPS \LISPFINISH ARGNAMES (DUMMY))

(PUTPROPS \GETPACKETBUFFER ARGNAMES NIL)

(PUTPROPS \GATHERSTATS ARGNAMES (FID))

(PUTPROPS \DSPRATE ARGNAMES (AC0 AC1 AC2))

(PUTPROPS DSPBOUT ARGNAMES (CHARCODE))

(PUTPROPS DISKPARTITION ARGNAMES NIL)

(PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR))

(PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE)
(PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992 
2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3635 6424 (MISCN-NUMBER 3645 . 3800) (\MISCN.UFN 3802 . 5257) (\UNDEFINED-MISCN-UFN 
5259 . 5527) (MISCN-COLLECT 5529 . 5696) (\GET-MY-BF 5698 . 5841) (\INIT-MISCN-TABLE 5843 . 6422)) (
7808 9097 (ADD-USER-SUBR 7808 . 9097)) (9098 10463 (\USER-SUBR-UFN 9108 . 9548) (\INIT-USER-SUBR-TABLE
 9550 . 9877) (\UNDEFINED-USER-SUBR-UFN 9879 . 10178) (USER-SUBR-NUMBER 10180 . 10341) (EQ-TO-CAR 
10343 . 10400) (EQ-TO-CADR 10402 . 10461)) (14726 15375 (SUBRNUMBER 14736 . 15373)) (15436 16843 (
WRITECALLSUBRS 15446 . 16346) (FIX-SUBR-NAME 16348 . 16841)) (17052 20999 (\MOREVMEMFILE 17062 . 17177
) (\WRITEMAP 17179 . 17292) (\COPYSYS0SUBR 17294 . 17399) (\PUPLEVEL1STATE 17401 . 17510) (SHOWDISPLAY
 17512 . 17750) (SETSCREENCOLOR 17752 . 17860) (\WRITERAWPBI 17862 . 17965) (\READRAWPBI 17967 . 18062
) (RAID 18064 . 18176) (\LISPFINISH 18178 . 18283) (\GETPACKETBUFFER 18285 . 18390) (\GATHERSTATS 
18392 . 18495) (\DSPRATE 18497 . 18652) (DSPBOUT 18654 . 18758) (DISKPARTITION 18760 . 18947) (
\CHECKBCPLPASSWORD 18949 . 19081) (SUSPEND-LISP 19083 . 19233) (UNIX-USERNAME 19235 . 19485) (
UNIX-FULLNAME 19487 . 19738) (UNIX-GETENV 19740 . 20337) (UNIX-GETPARM 20339 . 20997)))))
STOP
\ No newline at end of file
diff --git a/sources/LLSUBRS.LCOM b/sources/LLSUBRS.LCOM
index 7330734d..f4889509 100644
Binary files a/sources/LLSUBRS.LCOM and b/sources/LLSUBRS.LCOM differ
diff --git a/sources/LOADUP-FULL b/sources/LOADUP-FULL
index f5abef01..4817a4d3 100644
--- a/sources/LOADUP-FULL
+++ b/sources/LOADUP-FULL
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Feb-2021 16:56:12" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LOADUP-FULL.;2 8011   

      changes to%:  (FNS MAKEFULLSYSOUT)

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


(PRETTYCOMPRINT LOADUP-FULLCOMS)

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

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

(DEFCOMMAND "pwd" NIL (DIRECTORYNAME T))

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

(LOADFULLFONTS
  [LAMBDA (ROOTDIRECTORY)                                    (* ; 
                                                           "Edited 11-Aug-2020 17:53 by rmk:")

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

    (PRINTOUT T "Loading FULL fonts..." T)
    (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts")
                                       (PACK* ROOTDIRECTORY "/fonts/altofonts")))
                                                             (* (SETQ INTERPRESSFONTDIRECTORIES
                                                           (CONS (PACK* ROOTDIRECTORY 
                                                           "/fonts/ipfonts"))))
    (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE))
    (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts")))
    (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT)
    (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL)
                (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL))    (* ; 
                  "Don't let the font loader substitute just because a server went catatonic on us")
               (for FAMILY in '(CLASSIC MODERN TERMINAL)
                  do (PRINTOUT T "  Loading " FAMILY " ")
                        [for SIZE in '(8 10 12)
                           do (PRINTOUT T SIZE " ")
                                 (for FACE in '(MRR BRR MIR)
                                    do 

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

(MAKEFULLSYSOUT
  [LAMBDA NIL                                                (* ; 
                                                           "Edited  5-Dec-2020 20:07 by larry")
                                                             (* ; 
                                                           "Edited 14-May-2018 15:01 by kaplan")
                                                             (* ; 
                                                           "Edited 22-Feb-2021 16:56 by rmk:")
                                                             (* ; "Edited 17-Apr-2018 08:41 by ")
                                                             (* ; 
                                                           "Edited 21-Apr-2018 07:27 by rmk:")
                                                             (* ; "Edited 23-Feb-94 15:04 by bvm")
    (CLRPROMPT)
    (CNDIR (UNIX-GETENV "LOADUPDIR"))
    (LET ((ROOTDIRECTORY (MEDLEYDIR)))
         (SETQ MAKESYSFILENAME (CONCAT (MEDLEYDIR "loadups")
                                      "xfull35.sysout"))
         (DRIBBLE (PACKFILENAME 'EXTENSION 'DRIBBLE 'BODY MAKESYSFILENAME))

         (* ;; "BKSYSBUF stops page holding ")

         (PRINTOUT T T "Full loadup started at " (DATE)
                " while connected to "
                (DIRECTORYNAME T)
                T T)
         (BKSYSBUF " ")
         (SETQ DEFAULTFILETYPE 'BINARY)                      (* ; 
                                      "These prevent bits from being lost due to lack of knowledge")
         (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST)
                DEFAULTFILETYPELIST)                         (* (SETQ *UPPER-CASE-FILE-NAMES* NIL))
         (SETQ MAKESYSNAME :MEDLEY3.5)
         (push DEFAULTFILETYPELIST '(TXT . TEXT)
                '(TEXT . TEXT)
                '(TEX . TEXT)
                '(HTML . TEXT)
                '(HTM . TEXT))
         (MEDLEY-INIT-VARS)
         (SETQ LOADUPDIRECTORIES DIRECTORIES)
         (LOADUP '(POSTSCRIPTSTREAM))                        (* ; " to get PSCFONT.READFONT")
         (LOADFULLFONTS (MEDLEYDIR))
         (LISTPUT IDLE.PROFILE 'TIMEOUT 0)
         (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
         (LOADUP '(CHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES GRAPHER SPY
                        WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT UNICODE ISO8859IO
                        HELPSYS DINFO CLIPBOARD MODERNIZE))
         (FILESLOAD (SYSLOAD)
                PRETTYFILEINDEX WHO-LINE)
         (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP))

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

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

         (* ;; "From SYNCLISPFILES")

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

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

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

(FIXMETA
  [LAMBDA NIL                                                (* ; 
                                                           "Edited 25-Jun-2017 17:12 by rmk:")
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
           \CURRENTKEYACTION)
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)

(FIXMETA)

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

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

(MAKEFULLSYSOUT)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (885 7750 (LOADFULLFONTS 895 . 3399) (MAKEFULLSYSOUT 3401 . 7439) (FIXMETA 7441 . 7748))
)))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Feb-2021 16:56:12" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>LOADUP-FULL.;2 8011   

      changes to%:  (FNS MAKEFULLSYSOUT)

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


(PRETTYCOMPRINT LOADUP-FULLCOMS)

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

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

(DEFCOMMAND "pwd" NIL (DIRECTORYNAME T))

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

(LOADFULLFONTS
  [LAMBDA (ROOTDIRECTORY)                                    (* ; 
                                                           "Edited 11-Aug-2020 17:53 by rmk:")

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

    (PRINTOUT T "Loading FULL fonts..." T)
    (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts")
                                       (PACK* ROOTDIRECTORY "/fonts/altofonts")))
                                                             (* (SETQ INTERPRESSFONTDIRECTORIES
                                                           (CONS (PACK* ROOTDIRECTORY 
                                                           "/fonts/ipfonts"))))
    (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE))
    (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts")))
    (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT)
    (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL)
                (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL))    (* ; 
                  "Don't let the font loader substitute just because a server went catatonic on us")
               (for FAMILY in '(CLASSIC MODERN TERMINAL)
                  do (PRINTOUT T "  Loading " FAMILY " ")
                        [for SIZE in '(8 10 12)
                           do (PRINTOUT T SIZE " ")
                                 (for FACE in '(MRR BRR MIR)
                                    do 

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

(MAKEFULLSYSOUT
  [LAMBDA NIL                                                (* ; 
                                                           "Edited  5-Dec-2020 20:07 by larry")
                                                             (* ; 
                                                           "Edited 14-May-2018 15:01 by kaplan")
                                                             (* ; 
                                                           "Edited 22-Feb-2021 16:56 by rmk:")
                                                             (* ; "Edited 17-Apr-2018 08:41 by ")
                                                             (* ; 
                                                           "Edited 21-Apr-2018 07:27 by rmk:")
                                                             (* ; "Edited 23-Feb-94 15:04 by bvm")
    (CLRPROMPT)
    (CNDIR (UNIX-GETENV "LOADUPDIR"))
    (LET ((ROOTDIRECTORY (MEDLEYDIR)))
         (SETQ MAKESYSFILENAME (CONCAT (MEDLEYDIR "loadups")
                                      "xfull35.sysout"))
         (DRIBBLE (PACKFILENAME 'EXTENSION 'DRIBBLE 'BODY MAKESYSFILENAME))

         (* ;; "BKSYSBUF stops page holding ")

         (PRINTOUT T T "Full loadup started at " (DATE)
                " while connected to "
                (DIRECTORYNAME T)
                T T)
         (BKSYSBUF " ")
         (SETQ DEFAULTFILETYPE 'BINARY)                      (* ; 
                                      "These prevent bits from being lost due to lack of knowledge")
         (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST)
                DEFAULTFILETYPELIST)                         (* (SETQ *UPPER-CASE-FILE-NAMES* NIL))
         (SETQ MAKESYSNAME :MEDLEY3.5)
         (push DEFAULTFILETYPELIST '(TXT . TEXT)
                '(TEXT . TEXT)
                '(TEX . TEXT)
                '(HTML . TEXT)
                '(HTM . TEXT))
         (MEDLEY-INIT-VARS)
         (SETQ LOADUPDIRECTORIES DIRECTORIES)
         (LOADUP '(POSTSCRIPTSTREAM))                        (* ; " to get PSCFONT.READFONT")
         (LOADFULLFONTS (MEDLEYDIR))
         (LISTPUT IDLE.PROFILE 'TIMEOUT 0)
         (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
         (LOADUP '(CHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES GRAPHER SPY
                        WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT UNICODE ISO8859IO
                        HELPSYS DINFO CLIPBOARD MODERNIZE))
         (FILESLOAD (SYSLOAD)
                PRETTYFILEINDEX WHO-LINE)
         (SETQ *WHO-LINE-ANCHOR* '(:CENTER :TOP))

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

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

         (* ;; "From SYNCLISPFILES")

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

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

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

(FIXMETA
  [LAMBDA NIL                                                (* ; 
                                                           "Edited 25-Jun-2017 17:12 by rmk:")
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
           \CURRENTKEYACTION)
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)

(FIXMETA)

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

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

(MAKEFULLSYSOUT)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (885 7750 (LOADFULLFONTS 895 . 3399) (MAKEFULLSYSOUT 3401 . 7439) (FIXMETA 7441 . 7748))
)))
STOP
diff --git a/sources/LOADUP-FULL.LCOM b/sources/LOADUP-FULL.LCOM
index bb519b85..1599f26b 100644
Binary files a/sources/LOADUP-FULL.LCOM and b/sources/LOADUP-FULL.LCOM differ
diff --git a/sources/LOADUP-INIT.LISP b/sources/LOADUP-INIT.LISP
new file mode 100644
index 00000000..2c54250a
--- /dev/null
+++ b/sources/LOADUP-INIT.LISP
@@ -0,0 +1,10 @@
+(* "make init files")
+
+(CNDIR (MEDLEYDIR "tmp"))
+(MOVD 'NILL 'PAGEFULLFN)
+(LOAD (MEDLEYDIR "sources" "MAKEINITGREET.LCOM"))
+(PROGN (DRIBBLE "makeinit.dribble")
+       (BKSYSBUF " ")
+       (MAKEINITGREET)
+       (DRIBBLE)
+       (LOGOUT T))
diff --git a/sources/LOADUP-LISP b/sources/LOADUP-LISP
index ec4070c7..45d29593 100644
--- a/sources/LOADUP-LISP
+++ b/sources/LOADUP-LISP
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED " 6-Feb-2021 15:41:31" |{DSK}<home>larry>ilisp>medley>sources>LOADUP-LISP.;2| 7240   

      |changes| |to:|  (VARS LOADUP-LISPCOMS)

      |previous| |date:| " 5-Feb-2021 13:59:18" |{DSK}<home>larry>ilisp>medley>sources>LOADUP-LISP.;1|
)


(PRETTYCOMPRINT LOADUP-LISPCOMS)

(RPAQQ LOADUP-LISPCOMS
       ((FNS ENDLOADUP LOADUP-LISP MEDLEY-INIT-VARS MEDLEYDIR MEDLEYVERSION)
        (FILES SYNCLISPFILES)
        (VARS MEDLEY-INIT-VARS)
        (GLOBALVARS XCL::*WHERE-IS-CASH-FILES* LISPMAKESYSDATE MAKESYSFILENAME MEDLEY-INIT-VARS 
               MEDLEYDIR SYSTEMINITVARS USERRECLST)
        (FUNCTIONS WITHOUT.PAGEHOLD)
        (DECLARE\: DONTEVAL@LOAD DOCOPY (P (LOADUP-LISP)))))
(DEFINEQ

(ENDLOADUP
  (LAMBDA NIL                                           (* \; "Edited  5-Feb-2021 12:50 by lmm")
                                                             (* \; 
                                                           "Edited 10-Dec-2020 21:49 by larry")
                                                             (* \; "Edited 11-Oct-90 11:02 by jds")

    (* |;;| 
  "set up for NONET configuration;  sites with ethernet can load in init from other places")

    (* |;;| "All records existing at this point in time have been loaded as part of the system.")

    (MAPC USERRECLST (FUNCTION (LAMBDA (R)
                                 (AND R (RECORDPRIORITY R 'SYSTEM)))))
    (MEDLEY-INIT-VARS T)
    (|for| X |in| SYSTEMINITVARS |when| (NOT (ASSOC X MEDLEY-INIT-VARS))
       |do| (SETTOPVAL (CAR X)
                       (COPY (CDR X))))))

(LOADUP-LISP
  (LAMBDA NIL                                           (* \; "Edited  5-Feb-2021 13:59 by lmm")
    (DRIBBLE (MEDLEYDIR "loadups" "xlisp.dribble" T))

    (* |;;| " Use SYNCLISPFILES to make XLISP from LISP")

    (WITHOUT.PAGEHOLD (MEDLEY-INIT-VARS)
           (SETQ LISPMAKESYSDATE MAKESYSDATE)
           (SETQ MAKESYSFILENAME (MEDLEYDIR "loadups" "xlisp.sysout" T))
           (SYNCLISPFILES)
           (ENDLOADUP)
           (CLRPROMPT)
           (BKSYSBUF (CONCAT "(IL:MAKESYS \"" MAKESYSFILENAME "\" \"Medley Lisp Sysout\")"))
           (DRIBBLE))))

(MEDLEY-INIT-VARS
  (LAMBDA (CLEAR)                                     (* \; "Edited 17-Jan-2021 14:29 by larry")

    (* |;;| "MEDLEY-INIT-VARS has variables that might need to get reset. ")

    (|if| CLEAR
        |then| (SETQ MEDLEYDIR NIL)
              (SETQ XCL::*WHERE-IS-CASH-FILES* NIL)
              (|for| X |in| MEDLEY-INIT-VARS |do| (SET (CAR X)))
      |elseif| (OR (NOT (BOUNDP 'MEDLEYDIR))
                       (AND (NULL MEDLEYDIR)
                            (NULL (MEDLEYDIR))))
        |then| (PRINTOUT T "WARNING: MEDLEYDIR not set correctly" 
                          " set it and call (MEDLEY-INIT-VARS) again" T)
      |else| (|for| X |in| MEDLEY-INIT-VARS |do| (SET (CAR X)
                                                                      (EVAL (CADR X)))) 

            (* |;;| "WHEREIS doesn't follow conventions")

            (CL:WHEN (GETD 'XCL::ADD-WHERE-IS-DATABASE)
                (SETQ XCL::*WHERE-IS-CASH-FILES* NIL)
                (NLSETQ (XCL::ADD-WHERE-IS-DATABASE (MEDLEYDIR "loadups" "WHEREIS.HASH"))))
            NIL)))

(MEDLEYDIR
  (LAMBDA (DIRNAME FILENAME OUTPUT)                   (* \; "Edited 14-Dec-2020 17:12 by larry")
    (|if| (NULL DIRNAME)
        |then| (|if| (OR (NOT (BOUNDP 'MEDLEYDIR))
                                 (NOT MEDLEYDIR))
                       |then| (OR (SETQ MEDLEYDIR (DIRECTORYNAME (OR (UNIX-GETENV "MEDLEYDIR")
                                                                         T)))
                                      (DIRECTORYNAME T))
                     |elseif| (STRPOS "/" MEDLEYDIR)
                       |then| (SETQ MEDLEYDIR (DIRECTORYNAME MEDLEYDIR))
                     |else| MEDLEYDIR)
      |elseif| (LISTP DIRNAME)
        |then| (|for| X |in| DIRNAME |collect| (MEDLEYDIR X))
      |elseif| FILENAME
        |then| (SETQ FILENAME (CONCAT (MEDLEYDIR DIRNAME)
                                         FILENAME))
              (|if| OUTPUT
                  |then| FILENAME
                |else| (OR (INFILEP FILENAME)
                               (ERROR "No such medley file" FILENAME)))
      |else| (OR (DIRECTORYNAME (CONCAT (MEDLEYDIR)
                                           DIRNAME))
                     (ERROR "No such medley directory" DIRNAME)))))

(MEDLEYVERSION
  (LAMBDA NIL                                                (* \; 
                                                           "Edited 25-Mar-2018 22:07 by rmk:")
                                                             (* \; "Edited 11-Nov-98 22:02 by rmk:")
    (SELECTQ (LISPVERSION)
        (39424 '|1.1|)
        (39539 '|1.15|)
        (40960 '|1.2|)
        (4928 '|2.0|)
        (21000 '|2.1|)
        (35000 '|3.5|)
        (35010 '|3.5|)
        (HELP "UNRECOGNIZED MEDLEY VERSION" (LISPVERSION)))))
)

(FILESLOAD SYNCLISPFILES)

(RPAQQ MEDLEY-INIT-VARS
       ((LISPUSERSDIRECTORIES (MEDLEYDIR '("library" "lispusers" "internal/library")))
        (LISPSOURCEDIRECTORIES (MEDLEYDIR '("sources")))
        (LISPSOURCEDIRECTORY (CAR LISPSOURCEDIRECTORIES))
        (IRM.HOST&DIR (MEDLEYDIR '"docs/dinfo"))
        (IRM.DINFOGRAPH)
        (DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
        (LOGINHOST/DIR (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
                                          (UNIX-GETENV "HOME"))))
        (USERGREETFILES `((,LOGINHOST/DIR "INIT" COM)
                          (,LOGINHOST/DIR "INIT")))
        (DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/displayfonts" "fonts/altofonts")))
        (POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts")))
        (INTERPRESSFONTDIRECTORIES (MEDLEYDIR '("fonts/ipfonts")))
        (XCL::*WHERE-IS-CASH-FILES*)))
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS XCL::*WHERE-IS-CASH-FILES* LISPMAKESYSDATE MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR 
       SYSTEMINITVARS USERRECLST)
)

(DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS)
   `(RESETLST
        (LET* ((TTYWINDOW ,WINDOW)
               (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN))
               (NEW.PAGEFULLFN (FUNCTION NILL)))
              (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN)
                     (LIST (FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)
                                       (COND
                                          ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN)
                                               NEW.PAGEFULLFN)
                                           (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN)))))
                           TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)))
        ,@FORMS))
(DECLARE\: DONTEVAL@LOAD DOCOPY 

(LOADUP-LISP)
)
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (764 5304 (ENDLOADUP 774 . 1693) (LOADUP-LISP 1695 . 2304) (MEDLEY-INIT-VARS 2306 . 3451
) (MEDLEYDIR 3453 . 4756) (MEDLEYVERSION 4758 . 5302)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "13-Feb-2021 22:31:02" |{DSK}<home>larry>ilisp>medley>sources>LOADUP-LISP.;6| 5987   

      |changes| |to:|  (FNS ENDLOADUP)

      |previous| |date:| "13-Feb-2021 20:05:39" |{DSK}<home>larry>ilisp>medley>sources>LOADUP-LISP.;4|
)


(PRETTYCOMPRINT LOADUP-LISPCOMS)

(RPAQQ LOADUP-LISPCOMS ((FNS ENDLOADUP MEDLEY-INIT-VARS MEDLEYDIR)
                            (INITVARS (FILING.ENUMERATION.DEPTH T))
                            (VARS MEDLEY-INIT-VARS)
                            (GLOBALVARS XCL::*WHERE-IS-CASH-FILES* LISPMAKESYSDATE MAKESYSFILENAME 
                                   MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST)
                            (FUNCTIONS WITHOUT.PAGEHOLD)))
(DEFINEQ

(ENDLOADUP
  (LAMBDA NIL                                           (* \; "Edited 13-Feb-2021 19:26 by lmm")
                                                             (* \; "Edited 11-Oct-90 11:02 by jds")

    (* |;;| 
  "set up for NONET configuration;  sites with ethernet can load in init from other places")

    (* |;;| "All records existing at this point in time have been loaded as part of the system.")

    (MAPC USERRECLST (FUNCTION (LAMBDA (R)
                                 (AND R (RECORDPRIORITY R 'SYSTEM)))))
    (MEDLEY-INIT-VARS T)
    (|for| X |in| SYSTEMINITVARS |when| (NOT (ASSOC X MEDLEY-INIT-VARS))
       |do| (SETTOPVAL (CAR X)
                       (COPY (CDR X))))
    (|for| TYPE |in| FILEPKGTYPES |do| (FILEPKGCHANGES TYPE NIL))
    (CLRPROMPT)))

(MEDLEY-INIT-VARS
  (LAMBDA (CLEAR)                                     (* \; "Edited 17-Jan-2021 14:29 by larry")

    (* |;;| "MEDLEY-INIT-VARS has variables that might need to get reset. ")

    (|if| CLEAR
        |then| (SETQ MEDLEYDIR NIL)
              (SETQ XCL::*WHERE-IS-CASH-FILES* NIL)
              (|for| X |in| MEDLEY-INIT-VARS |do| (SET (CAR X)))
      |elseif| (OR (NOT (BOUNDP 'MEDLEYDIR))
                       (AND (NULL MEDLEYDIR)
                            (NULL (MEDLEYDIR))))
        |then| (PRINTOUT T "WARNING: MEDLEYDIR not set correctly" 
                          " set it and call (MEDLEY-INIT-VARS) again" T)
      |else| (|for| X |in| MEDLEY-INIT-VARS |do| (SET (CAR X)
                                                                      (EVAL (CADR X)))) 

            (* |;;| "WHEREIS doesn't follow conventions")

            (CL:WHEN (GETD 'XCL::ADD-WHERE-IS-DATABASE)
                (SETQ XCL::*WHERE-IS-CASH-FILES* NIL)
                (NLSETQ (XCL::ADD-WHERE-IS-DATABASE (MEDLEYDIR "loadups" "WHEREIS.HASH"))))
            NIL)))

(MEDLEYDIR
  (LAMBDA (DIRNAME FILENAME OUTPUT)                   (* \; "Edited 14-Dec-2020 17:12 by larry")
    (|if| (NULL DIRNAME)
        |then| (|if| (OR (NOT (BOUNDP 'MEDLEYDIR))
                                 (NOT MEDLEYDIR))
                       |then| (OR (SETQ MEDLEYDIR (DIRECTORYNAME (OR (UNIX-GETENV "MEDLEYDIR")
                                                                         T)))
                                      (DIRECTORYNAME T))
                     |elseif| (STRPOS "/" MEDLEYDIR)
                       |then| (SETQ MEDLEYDIR (DIRECTORYNAME MEDLEYDIR))
                     |else| MEDLEYDIR)
      |elseif| (LISTP DIRNAME)
        |then| (|for| X |in| DIRNAME |collect| (MEDLEYDIR X))
      |elseif| FILENAME
        |then| (SETQ FILENAME (CONCAT (MEDLEYDIR DIRNAME)
                                         FILENAME))
              (|if| OUTPUT
                  |then| FILENAME
                |else| (OR (INFILEP FILENAME)
                               (ERROR "No such medley file" FILENAME)))
      |else| (OR (DIRECTORYNAME (CONCAT (MEDLEYDIR)
                                           DIRNAME))
                     (ERROR "No such medley directory" DIRNAME)))))
)

(RPAQ? FILING.ENUMERATION.DEPTH T)

(RPAQQ MEDLEY-INIT-VARS
       ((LISPUSERSDIRECTORIES (MEDLEYDIR '("library" "lispusers" "internal/library")))
        (LISPSOURCEDIRECTORIES (MEDLEYDIR '("sources")))
        (LISPSOURCEDIRECTORY (CAR LISPSOURCEDIRECTORIES))
        (IRM.HOST&DIR (MEDLEYDIR '"docs/dinfo"))
        (IRM.DINFOGRAPH)
        (DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
        (LOGINHOST/DIR (DIRECTORYNAME (OR (UNIX-GETENV "LOGINDIR")
                                          (UNIX-GETENV "HOME"))))
        (USERGREETFILES `((,LOGINHOST/DIR "INIT" COM)
                          (,LOGINHOST/DIR "INIT")))
        (DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/displayfonts" "fonts/altofonts")))
        (POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts")))
        (INTERPRESSFONTDIRECTORIES (MEDLEYDIR '("fonts/ipfonts")))
        (XCL::*WHERE-IS-CASH-FILES*)))
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS XCL::*WHERE-IS-CASH-FILES* LISPMAKESYSDATE MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR 
       SYSTEMINITVARS USERRECLST)
)

(DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS)
   `(RESETLST
        (LET* ((TTYWINDOW ,WINDOW)
               (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN))
               (NEW.PAGEFULLFN (FUNCTION NILL)))
              (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN)
                     (LIST (FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)
                                       (COND
                                          ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN)
                                               NEW.PAGEFULLFN)
                                           (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN)))))
                           TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)))
        ,@FORMS))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (783 4092 (ENDLOADUP 793 . 1638) (MEDLEY-INIT-VARS 1640 . 2785) (MEDLEYDIR 2787 . 4090))
)))
STOP
\ No newline at end of file
diff --git a/sources/LOADUP-LISP.LCOM b/sources/LOADUP-LISP.LCOM
index 132c1da6..84c1050b 100644
Binary files a/sources/LOADUP-LISP.LCOM and b/sources/LOADUP-LISP.LCOM differ
diff --git a/sources/LOADUP.LISP b/sources/LOADUP.LISP
index cb9f28c1..5f2c4783 100644
--- a/sources/LOADUP.LISP
+++ b/sources/LOADUP.LISP
@@ -1 +1,53 @@
-(SETQQ COMPILE.EXT LCOM)

(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES))

(SETQ BOOTLOADEDFILES)

(* "following files are really loaded earlier, this call to LOADUP just cleans up")
(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP)))

(* "establish all package exports early")
(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE)))

(* "turn on FTP so that loadup will be faster")
(LOADUP (QUOTE (BSP DPUPFTP)))

(* "load FASL loader here, so we can load DFASLs earlier in loadup")
(LOADUP (QUOTE (ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD)))

(* "These are needed by any FASL files")
(LOADUP (QUOTE (DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON CMLSEQMAPPERS CMLPATHNAME CMLFILESYS)))

(* * * "FASL files may be loaded after this point" * * *)

(LOADUP (QUOTE (CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS)))

(* "early runtime support for Common Lisp and (temporarily) debugger")
(LOADUP (QUOTE (STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS)))

(LOADUP (QUOTE (COMMON XCLC-RUNTIME CMLTYPES CL-ERROR)))

(LOADUP (QUOTE (AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE)))

(* "The Byte Compiler (DLAP, BYTECOMPILER, COMPILER) used to be here.  Moved after
    XCL Compiler so that one byte compiler init will work.  JDS 10/11/89")

(LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD)))

(LOADUP (QUOTE (GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE)))

(DWIM (QUOTE C))

(* "Kernel Common Lisp files")
(LOADUP (QUOTE (CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES)))

(LOADUP (QUOTE (PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT)))

(LOADUP (QUOTE (ADDARITH)))

(LOADUP (QUOTE (CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON LOGOW PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)))

(LOADUP (QUOTE (BREAK-AND-TRACE)))

(LOADUP (QUOTE (FASDUMP XCL-COMPILER ADVISE)))

(* "the bytecompiler and Interlisp compiler interface functions")
(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE)))


(LOADUP (QUOTE (DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER MAIKOETHER LLNS TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS FLOPPY IDLER ICONW FREEMENU SEDIT)))

(LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT)))

(LOADUP (QUOTE (TIME)))

(LOADUP (QUOTE (XCL-EXTRAS)))

(* "CMLPACKAGE pushes onto INSPECTMACROS")
(LOADUP (QUOTE (CMLPACKAGE)))

(* "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs")
(LOADUP (QUOTE (CMLSMARTARGS)))

(LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE)))

(* "Already enabled, but this time fixes tables that weren't defined in the init")
(PACKAGE-ENABLE)

STOP
\ No newline at end of file
+(SETQQ COMPILE.EXT LCOM)
+(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES))
+(SETQ BOOTLOADEDFILES)
+(* ;; "following files are really loaded earlier, this call to LOADUP just cleans up")
+(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP)))
+(* ;; "establish all package exports early")
+(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE)))
+(* ;; "load FASL loader here, so we can load DFASLs earlier in loadup")
+(LOADUP (QUOTE (ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD)))
+(* ;; "These are needed by any FASL files")
+(LOADUP (QUOTE (DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON CMLSEQMAPPERS CMLPATHNAME CMLFILESYS)))
+(* ;;; "* 'FASL files may be loaded after this point' * * *")
+(LOADUP (QUOTE (CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS)))
+(* ;; "early runtime support for Common Lisp and (temporarily) debugger")
+(LOADUP (QUOTE (STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS)))
+(LOADUP (QUOTE (COMMON XCLC-RUNTIME CMLTYPES CL-ERROR)))
+(LOADUP (QUOTE (AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS 
+DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE)))
+(* ;; "needed for makesys")
+(LOADUP (QUOTE (MOD44IO)))
+(* ;; 
+"The Byte Compiler (DLAP, BYTECOMPILER, COMPILER) used to be here.  Moved after    XCL Compiler so that one byte compiler init will work.  JDS 10/11/89"
+)
+(LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD)))
+(LOADUP (QUOTE (GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE)))
+(DWIM (QUOTE C))
+(* ;; "Kernel Common Lisp files")
+(LOADUP (QUOTE (CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES)))
+(LOADUP (QUOTE (PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT)))
+(LOADUP (QUOTE (ADDARITH)))
+(LOADUP (QUOTE (CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)))
+(LOADUP (QUOTE (BREAK-AND-TRACE)))
+(LOADUP (QUOTE (FASDUMP XCL-COMPILER ADVISE)))
+(* ;; "the bytecompiler and Interlisp compiler interface functions")
+(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE)))
+(LOADUP (QUOTE (HARDCOPY LOGOW IDLER ICONW FREEMENU SEDIT)))
+(CLOSEW (LOGOW)) (MOVD 'NILL 'LOGOW)
+(LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT)))
+(LOADUP (QUOTE (TIME)))
+(LOADUP (QUOTE (XCL-EXTRAS)))
+(* "CMLPACKAGE pushes onto INSPECTMACROS")
+(LOADUP (QUOTE (CMLPACKAGE)))
+(* ;; 
+"Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs"
+)
+(LOADUP (QUOTE (CMLSMARTARGS)))
+(LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE)))
+(* ;; "Already enabled, but this time fixes tables that weren't defined in the init")
+ (PACKAGE-ENABLE)
+ (* ;; "Additional stuff that should be folded into original definitions")
+  (LOADUP (QUOTE (LOADUP-LISP)))
+  STOP
+  
diff --git a/sources/MAIKOINIT b/sources/MAIKOINIT
new file mode 100755
index 00000000..a57ccc94
--- /dev/null
+++ b/sources/MAIKOINIT
@@ -0,0 +1,7 @@
+
+(RPAQQ SI::*CLOSURE-CACHE-ENABLED* NIL)
+
+(QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT* ))
+
+(PUTPROPS MAIKOINIT COPYRIGHT ("Venue" 1990))
+STOP
diff --git a/sources/MAKEINIT b/sources/MAKEINIT
index 895c1666..bbef8e56 100644
--- a/sources/MAKEINIT
+++ b/sources/MAKEINIT
@@ -1,143 +1,4 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "30-Jan-98 12:46:00" {DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>MAKEINIT.;3 26173  
-
-      changes to%:  (FNS I.\ATOMCELL)
-
-      previous date%: "30-Jan-98 12:10:24" 
-{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>MAKEINIT.;2)
-
-
-(* ; "
-Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1998 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT MAKEINITCOMS)
-
-(RPAQQ MAKEINITCOMS 
-       ((FNS LOADMAKEINIT LOADMKIFILES RELOAD MAKEINIT MKI.START)
-        (COMS                                                (* ; 
-                                     "reading compiled files and processing well-known expressions")
-              (FNS MKI.PASSFILE SCRATCHARRAY DOFORM CONSTFORMP NOTICECOMS EVALFORMAKEINIT)
-              (FNS I.ADDTOVAR I.DECLARE%: I.DEFINE-FILE-INFO I.FILECREATED I.PUTPROPS I.RPAQ I.RPAQQ
-                   I.RPAQ? I.SETTOPVAL I.NOUNDO)
-              (PROP MKI ADDTOVAR DECLARE%: DEFINE-FILE-INFO FILECREATED PUTPROPS RPAQ RPAQ? RPAQQ 
-                    LISPXPRINT PRETTYCOMPRINT * SETTOPVAL SETQQ SETQ /SETTOPVAL))
-        (FNS I.ATOMNUMBER I.\ATOMCELL I.FIXUPNUM I.FIXUPPTR I.FIXUPSYM I.WORDSPERNAMEENTRY 
-             I.SETSTKNTOFFSET)
-        (COMS                                                (* ; "stuff for MAXC")
-              (FNS MKI.ATOM MKI.IEEE))
-        [COMS                                                (* ; 
-                  "stuff to maintain symbol values, prop lists during makeinit--all dumped at end.")
-              (FNS MKI.DSET MKI.ADDTO MKI.PUTPROP)
-              (VARS (MKI.ARRAY)
-                    (MKI.TVHA (HASHARRAY 400))
-                    (MKI.PLHA (HASHARRAY 150))
-                    (MKI.ATOMARRAY (HASHARRAY 5000))
-                    (INIT.EXT 'SYSOUT]
-        (COMS (FNS DUMPVP BOUTZEROS BIN16 BOUT16)
-              (VARS (MKI.FirstDataByte 1024)
-                    (MKI.Page0Byte 512)
-                    (MKI.DATE (DATE))
-                    MKI.CODESTARTOFFSET MKI.SEQUENTIAL PRINTEXPRS))
-        (INITVARS (PRINTEXPRS T)
-               (REMOTECOMPILE.EXT COMPILE.EXT))
-        [DECLARE%: DONTEVAL@LOAD DOCOPY (P (PUTPROP (NAMEFIELD (INPUT)
-                                                           T)
-                                                  'LOADDATE
-                                                  (GETFILEINFO (INPUT)
-                                                         'ICREATIONDATE]
-        (DECLARE%: EVAL@COMPILE (PROP MACRO SETXVAR IEQ)
-               DONTCOPY
-               (FILES (LOADCOMP)
-                      MEM))))
-(DEFINEQ
-
-(LOADMAKEINIT
(LAMBDA (LARGEFLG) (* lmm "31-JUL-81 14:27") (SELECTQ (SYSTEMTYPE) ((D ALTO)) (PROGN (ADDTOVAR DIRECTORIES BLISP) (GCGAG 1000) (COND ((NOT LARGEFLG) (SETSEPR (QUOTE (%| 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26)) 1 FILERDTBL) (MINFS 45000 (QUOTE ARRAYP)) (MINFS 10000 (QUOTE FIXP)) (MINFS 3000 (QUOTE STRING.CHARS)) (MINFS 2000 (QUOTE ATOM.CHARS)))) (MOVD? (QUOTE NILL) (QUOTE MKNUMATOM)) (* ;; "This is a kludge to get around the problem that, while MKATOM is in LLNEW, MKNUMATOM is not, and MKATOM calls MKNUMATOM when given an atom beginning with a digit.  It turns out that MKNUMATOM will always return NIL in the cases called from MAKEINIT because MAKEINIT is merely copying things which it knows are really LITATOM and spelled like it.") (MOVD? (QUOTE *) (QUOTE BLOCKRECORD)) (PUTDQ? FIXSPELL1 (LAMBDA (OLD NEW) (PRINT (LIST OLD (QUOTE ->) NEW) T T))))) (LOADMKIFILES) (SELECTQ (SYSTEMTYPE) ((D ALTO)) (PROGN (MINFS 10000 (QUOTE ALTOPOINTER)) (* ; "doesn't work until after datatype declaration has been loaded") (RECLAIM (QUOTE ARRAYP)) (RECLAIM (QUOTE ATOM.CHARS)) (MINFS 10000 (QUOTE ARRAYP)) (MINFS 5000 (QUOTE LISTP)) (SYSOUT (QUOTE MKI.SAV)))))
)
-
-(LOADMKIFILES
(LAMBDA NIL (* mjs "13-Mar-84 14:41") (for X in (UNION MAKEINITFILES (SELECTQ (SYSTEMTYPE) ((ALTO D) NIL) MAXC.MAKEINITFILES)) do (RELOAD (PACKFILENAME (QUOTE BODY) X (QUOTE EXTENSION) COMPILE.EXT))))
)
-
-(RELOAD
(LAMBDA (FILE) (* lmm "13-APR-81 21:16") (PROG (DATE FULLFILENAME) RETRY (COND ((ILESSP (OR (GETPROP FILE (QUOTE LOADDATE)) MIN.INTEGER) (SETQ DATE (GETFILEINFO (SETQ FULLFILENAME (OR (FINDFILE FILE T) (GO NOTFOUND))) (QUOTE ICREATIONDATE)))) (LOAD FULLFILENAME T) (PUTPROP FILE (QUOTE LOADDATE) DATE))) (RETURN T) NOTFOUND (COND ((GETP (NAMEFIELD FILE) (QUOTE FILEDATES)) (PRINT (CONS FILE (QUOTE (already loaded))) T) (RETURN))) (ERROR FILE "not found.") (GO RETRY)))
)
-
-(MAKEINIT
  [LAMBDA (VERSIONS TYPE TOFILE LOADUPDIRS FONTDIRS)     (* ; "Edited 19-Jul-90 17:26 by jds")
    (LOADMKIFILES)                                       (* ; 
                                    "Load the files that have to be here to start making the init.")
    (PROG ([TYPELST (OR (LISTP TYPE)
                        (OR (CDR (ASSOC TYPE MAKEINITTYPES))
                            (ERROR TYPE '?]
           FILES SIZEGUESS AFTERINITFILESET EXPRESSIONS)

     (* ;; "TYPELST is a list of the form (type file-list after-init-files init-size-guess)")

          (SETQ FILES (CADR TYPELST))
          (SETQ AFTERINITFILESET (CADDR TYPELST))
          (SETQ SIZEGUESS (CADDDR TYPELST))
          (RESETLST
              [RESETSAVE (OUTPUT (SETQ TOFILE
                                  (OPENSTREAM (PACKFILENAME.STRING 'BODY (OR TOFILE (CAR TYPELST)
                                                                             'XXX)
                                                     'EXTENSION INIT.EXT)
                                         'OUTPUT
                                         'NEW 8 (COND
                                                   [NIL      (* ; 
                             "Can't do this until we can do GETFILEPTR on a sequential output file")
                                                        (APPEND MKI.SEQUENTIAL '((TYPE BINARY))
                                                               (AND SIZEGUESS
                                                                    (CONS (LIST 'LENGTH
                                                                                (UNFOLD SIZEGUESS 
                                                                                       BYTESPERPAGE]
                                                   (T '((TYPE BINARY]
              (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (FL)
                                               (AND (OPENP FL)
                                                    (CLOSEF FL))
                                               (AND RESETSTATE (DELFILE (FULLNAME FL]
                                   TOFILE))
              (PROG ((OUTX TOFILE))
                    (SETQ DIRECTORIES LOADUPDIRS)
                    (MKI.START)
                    (for X in FILES do (MKI.PASSFILE X))

               (* ;; "Generally loads the files in 0LISPSET and 1LISPSET, with 2LISPSET getting loaded immediately after the init starts.")

                    (AND LOADUPDIRS (MKI.DSET 'LOADUPDIRECTORIES LOADUPDIRS))
                    (AND FONTDIRS (MKI.DSET 'DISPLAYFONTDIRECTORIES FONTDIRS))
                    [COND
                       (AFTERINITFILESET                     (* ; "Load stuff that has to be loaded before we can call LOADUP.  Ugly expression here is because FILESLOAD is on MACHINEINDEPENDENT.")
                        [MKI.ADDTO
                         'MAKEINIT.EXPRESSIONS
                         `((MAPC ',(EVAL AFTERINITFILESET)
                                 (FUNCTION (LAMBDA (FILE)
                                             (OR [SOME LOADUPDIRECTORIES
                                                       (FUNCTION (LAMBDA (DIR FL)
                                                                   (COND
                                                                      ((SETQ FL
                                                                        (INFILEP (PACKFILENAME.STRING
                                                                                  'DIRECTORY DIR
                                                                                  'NAME FILE
                                                                                  'EXTENSION 
                                                                                  COMPILE.EXT)))
                                                                       (LOAD FL 'SYSLOAD)
                                                                       T]
                                                 (PRINT (CONS FILE '(not found))
                                                        T]
                        (MKI.ADDTO 'BOOTFILES '(MAKEINIT.EXPRESSIONS]
                    (I.MAKEINITLAST VERSIONS)))
          (RETURN (FULLNAME TOFILE])
-
-(MKI.START
(LAMBDA NIL (* bvm%: "12-Dec-84 15:23") (SETQ RESETPTR) (SETQ RESETPC) (BOUTZEROS MKI.FirstDataByte) (CLRHASH MKI.TVHA) (CLRHASH MKI.PLHA) (CLRHASH MKI.ATOMARRAY) (RESETMEMORY) (SETQ MKI.VALUES (for X in INITVALUES bind Y collect (SET (SETQ Y (PACK* "I." (SUBSTRING (CAR X) 2 -1))) (EVAL (CADR X))) Y)) (SETQ MKI.PTRS (for X in INITPTRS bind Y collect (SET (SETQ Y (PACK* "I." (SUBSTRING (CAR X) 2 -1))) (CADR X)) Y)) (I.MAKEINITFIRST) (MKI.DSET NIL NIL) (MKI.DSET T T) (MKI.DSET (QUOTE MAKEINITDATES) (LIST MKI.DATE (DATE))) (for X in INITCONSTANTS when (NEQ (CAR X) (QUOTE *)) do (I.FSETVAL (CAR X) (COND ((LISTP (CADR X)) (I.VAG2 (CAADR X) (CADR (CADR X)))) (T (I.\COPY (CADR X)))))))
)
-)
-
-
-
-(* ; "reading compiled files and processing well-known expressions")
-
-(DEFINEQ
-
-(MKI.PASSFILE
(LAMBDA (FILESET) (* ; "Edited 30-Mar-87 17:17 by bvm:") (* ;;; "Read a DCOM file and load its contents into the INIT.") (* ;;; "FILESET can be one of a number, which is a LISPSET number, or a list of file names, or a file name") (COND ((NUMBERP FILESET) (* ; "We were given a nLISPSET number.  Pack it up to get the list of files") (MKI.PASSFILE (EVALV (PACK* FILESET (QUOTE LISPSET))))) ((LISTP FILESET) (* ; "We were given a list of file names") (MAPC FILESET (FUNCTION MKI.PASSFILE))) (T (* ; "It's a file name.  Read it in.") (INPUT (SETQ FILESET (OPENSTREAM (OR (FINDFILE (PACKFILENAME.STRING (QUOTE BODY) FILESET (QUOTE EXTENSION) REMOTECOMPILE.EXT) T) FILESET) (QUOTE INPUT) (QUOTE OLD) 8 MKI.SEQUENTIAL))) (MKI.ADDTO (QUOTE LOADEDFILELST) (LIST (SETQ FILESET (FULLNAME FILESET)))) (PRINT FILESET T T) (LET* ((FILEROOT (NAMEFIELD FILESET)) (COMSNAMES (LIST (PACK* FILEROOT (QUOTE COMS)))) SKIPVARS MEXPRS X) (DECLARE (SPECVARS COMSNAMES SKIPVARS MEXPRS)) (* ; " used by I.RPAQQ and DOFORM") (* ;;; "Loop here reading from the dcom file into the init.") (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (until (SELECTQ (SETQ X (READ)) ((STOP NIL) (* ; "End of file") T) NIL) do (COND ((NLISTP X) (* ;; "Start of a code object.  Skip the code indicator (assume it says to read with DCODERD) and read the code") (IF (NOT (LITATOM (READ))) THEN (ERROR "Bad compiled function" X)) (I.DCODERD X)) (T (* ; "It's a form.  go either do it now or add it to the forms to execute inside the init.") (DOFORM X))) finally (COND ((CAR MEXPRS) (* ; "There are expressions to be executed in the INIT when it comes up.  Save them.") (MKI.ADDTO (SETQ FILESET (PACK* FILEROOT ".EXPRESSIONS")) (CAR MEXPRS)) (MKI.ADDTO (QUOTE BOOTFILES) (LIST FILESET)))))) (CLOSEF (INPUT))))))
)
-
-(SCRATCHARRAY
(LAMBDA (NBYTES ALIGN) (* ; "Edited 30-Mar-87 16:20 by bvm:") (COND ((OR (NULL MKI.ARRAY) (IGREATERP NBYTES (ARRAYSIZE MKI.ARRAY))) (* ;; "make sure the scratch array is big enough.  Note that the scratch array is unboxed, not code, since we aren't going to be storing legitimate local code in it (let's not fool the garbage collector too much).") (SETQ MKI.ARRAY (create ARRAYP TYP _ \ST.BYTE BASE _ (\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL) UNBOXEDBLOCK.GCT 0 CELLSPERQUAD) LENGTH _ NBYTES ORIG _ 0)))) (for I from 0 to (SUB1 (UNFOLD ALIGN BYTESPERCELL)) do (\BYTESETA MKI.ARRAY I 0)) (* ; "clear the fnheader area") MKI.ARRAY)
)
-
-(DOFORM
(LAMBDA (X NOPROP) (* bvm%: "30-Aug-86 15:36") (* ;;; "Handle a raw form found in a dcom file that's going into a makeinit.") (LET ((FN (GETPROP (CAR X) (QUOTE MKI)))) (if (AND FN (NOT NOPROP)) then (* ; "it's a local command that can be run `renamed' .  Execute it in the local context.") (* ASSERT%: (CALLS I.ADDTOVAR I.DECLARE%: I.DEFINE-FILE-INFO I.DEFLIST I.FILECREATED I.PRETTYDEFMACROS I.PUTPROPS I.RPAQ I.RPAQQ I.SETHASHQ)) (APPLY* FN X) else (* ;; "it's a command that has to be done remotely, since we don't know how to do it from here.  Add it to the collection of init expressions.") (COND (PRINTEXPRS (PRINT X T T))) (SETQ MEXPRS (TCONC MEXPRS X)))))
)
-
-(CONSTFORMP
(LAMBDA (X) (* lmm " 7-MAR-80 08:54") (COND ((LISTP X) (SELECTQ (CAR X) ((QUOTE FUNCTION) X) NIL)) ((LITATOM X) (SELECTQ X (NIL (QUOTE (QUOTE NIL))) (T T) (AND (SETQ X (GETHASH X MKI.TVHA)) (KWOTE (CDR X))))) (T X)))
)
-
-(NOTICECOMS
(LAMBDA (VAL) (* lmm "10-Mar-85 14:51") (for X in VAL when (LISTP X) do (COND ((AND (EQ (CADR X) (QUOTE *)) (LITATOM (CADDR X))) (COND ((EQ (CAR X) (QUOTE COMS)) (push COMSNAMES (CADDR X))) (T (push SKIPVARS (CADDR X))))) (T (SELECTQ (CAR X) ((COMS DECLARE%:) (NOTICECOMS (CDR X))) NIL)))))
)
-
-(EVALFORMAKEINIT
(LAMBDA (FORM) (* bvm%: " 2-NOV-83 15:22") (COND ((LISTP FORM) (SELECTQ (CAR FORM) (MKATOM (COND ((STRINGP (CADR FORM)) (MKATOM (CADR FORM))) (T (HELP)))) (HELP))) ((FIXP FORM) FORM) (T (HELP))))
)
-)
-(DEFINEQ
-
-(I.ADDTOVAR
(LAMBDA (FORM) (* lmm " 2-DEC-81 23:58") (MKI.ADDTO (CADR FORM) (CDDR FORM))))
-
-(I.DECLARE%:
(LAMBDA (FORM) (* lmm "18-FEB-80 14:04") (PROG ((L FORM) (FLAG T) X FN) LP (COND ((NULL (SETQ L (CDR L))) (RETURN)) ((NLISTP (SETQ X (CAR L))) (SELECTQ X ((EVAL@LOAD DOEVAL@LOAD) (SETQ FLAG T)) (DONTEVAL@LOAD (SETQ FLAG NIL)) NIL)) (T (DOFORM X))) (GO LP)))
)
-
-(I.DEFINE-FILE-INFO
(LAMBDA (FORM) (* bvm%: "30-Aug-86 15:32") (* ;;; "Set reader environment for reading rest of file") (SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO NIL (CDR FORM))))
)
-
-(I.FILECREATED
(LAMBDA (X) (* ; "Edited 12-Jan-88 11:00 by bvm") (* ;; "Form is (FILECREATED date filename . otherstuff)") (COND ((NLISTP (CADDR X)) (* ; "FILENAME a list is for the %"compiled on%" expression") (LET ((NAME (NAMEFIELD (CADDR X)))) (MKI.ADDTO (QUOTE BOOTLOADEDFILES) (LIST NAME)) (MKI.PUTPROP NAME (QUOTE FILEDATES) (LIST (CONS (CADR X) (CADDR X))))))))
)
-
-(I.PUTPROPS
(LAMBDA (FORM) (* lpd%: "29-APR-77 13:22") (MKI.PUTPROP (CADR FORM) (CADDR FORM) (CADDDR FORM))))
-
-(I.RPAQ
(LAMBDA (FORM) (* edited%: "10-Jul-84 14:05") (PROG ((VAL (CADDR FORM)) V) (COND ((SETQ V (CONSTFORMP VAL)) (MKI.DSET (CADR FORM) (EVAL V))) (T (DOFORM (LIST (QUOTE SETTOPVAL) (KWOTE (CADR FORM)) VAL) T)))))
)
-
-(I.RPAQQ
(LAMBDA (FORM) (* lmm "30-APR-80 22:12") (PROG ((ATM (CADR FORM)) (VAL (CADDR FORM))) (COND ((FMEMB ATM COMSNAMES) (NOTICECOMS VAL)) ((FMEMB ATM SKIPVARS)) (T (MKI.DSET ATM VAL)))))
)
-
-(I.RPAQ?
(LAMBDA (FORM) (* lmm " 7-MAR-80 08:36") (PROG ((VAL (CADDR FORM)) V) (COND ((SETQ V (CONSTFORMP VAL)) (MKI.DSET (CADR FORM) (EVAL V))) (T (DOFORM (LIST (QUOTE SETTOPVAL) (KWOTE (CADR FORM)) VAL))))))
)
-
-(I.SETTOPVAL
(LAMBDA (FORM) (* edited%: "10-Jul-84 14:07") (PROG (V) (if (AND (EQ (CAR (LISTP (CADR FORM))) (QUOTE QUOTE)) (SETQ V (CONSTFORMP (CADDR FORM)))) then (MKI.DSET (CADR (CADR FORM)) (EVAL V)) else (DOFORM FORM T))))
)
-
-(I.NOUNDO
(LAMBDA (FORM) (* edited%: "10-Jul-84 14:02") (if (EQ (NTHCHAR (CAR FORM) 1) (QUOTE /)) then (DOFORM (CONS (SUBATOM (CAR FORM) 2 -1) (CDR FORM))) else (SHOULDNT)))
)
-)
-
-(PUTPROPS ADDTOVAR MKI I.ADDTOVAR)
-
-(PUTPROPS DECLARE%: MKI I.DECLARE%:)
-
-(PUTPROPS DEFINE-FILE-INFO MKI I.DEFINE-FILE-INFO)
-
-(PUTPROPS FILECREATED MKI I.FILECREATED)
-
-(PUTPROPS PUTPROPS MKI I.PUTPROPS)
-
-(PUTPROPS RPAQ MKI I.RPAQ)
-
-(PUTPROPS RPAQ? MKI I.RPAQ?)
-
-(PUTPROPS RPAQQ MKI I.RPAQQ)
-
-(PUTPROPS LISPXPRINT MKI NILL)
-
-(PUTPROPS PRETTYCOMPRINT MKI NILL)
-
-(PUTPROPS * MKI NILL)
-
-(PUTPROPS SETTOPVAL MKI I.SETTOPVAL)
-
-(PUTPROPS SETQQ MKI I.RPAQQ)
-
-(PUTPROPS SETQ MKI I.RPAQ)
-
-(PUTPROPS /SETTOPVAL MKI I.NOUNDO)
-(DEFINEQ
-
-(I.ATOMNUMBER
  [LAMBDA (A)                                 (* ; 
                                                "Edited 27-Oct-92 14:10 by sybalsky:mv:envos")

    (* ;; "Given a symbol, return the symbol's atom #, in the INIT being made.")

    (* ;; 
"NB that this will work only so long as there are no NEW-SYMBOLs in the INIT, because of the LOLOC.")

    (I.LOLOC (COND
                ((LITATOM A)
                 (MKI.ATOM A))
                (T A])
-
-(I.\ATOMCELL
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 7-Feb-2021 18:08:30" {DSK}<home>larry>ilisp>medley>sources>MAKEINIT.;6 25695  

      changes to%:  (FILES MEM)
                    (FNS MAKEINIT LOADMKIFILES)
                    (VARS MAKEINITCOMS)

      previous date%: " 7-Feb-2021 17:49:57" {DSK}<home>larry>ilisp>medley>sources>MAKEINIT.;5)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1998, 2021 by Venue & Xerox Corporation.
")

(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                                            (* ; "Edited  7-Feb-2021 17:39 by lmm")
                                                             (* mjs "13-Mar-84 14:41")
    (for X in MAKEINITFILES do (RELOAD (PACKFILENAME 'BODY X '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 TOFILE TYPE LOADUPDIRS FONTDIRS)     (* ; "Edited  7-Feb-2021 17:46 by lmm")
                                                             (* ; "Edited 19-Jul-90 17:26 by jds")
    (LOADMKIFILES)
    (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]
              (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)))
@@ -175,112 +36,4 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1998 b
                                  (2 6)
                                  (8 0)
                                  (SHOULDNT]
-                    (I.ADDBASE ATOMNO OFFSET])
-
-(I.FIXUPNUM
  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited 17-Jul-90 14:28 by jds")

    (* ;; "�2�Perform atom-number fixup for a code block.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)

        (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.")

        (I.FIXUPPTR CA BN NUM))
       (T 
          (* ;; "Otherwise, fill in the two bytes.")

          (\BYTESETA CA (SUB1 BN)
                 (LOGOR (LOGAND (\BYTELT CA (SUB1 BN))
                               (LRSH (LOGXOR MASK 65535)
                                     8))
                        (LOGAND (LRSH (LOGAND NUM MASK)
                                      8)
                               255)))
          (\BYTESETA CA BN (LOGAND NUM 255])
-
-(I.FIXUPPTR
  [LAMBDA (CA BN PTR)                                    (* ; "Edited 22-Jul-90 12:10 by jds")

    (* ;; "Specific for MAXC --- actual ptr is same as simulated ptr")

    (PROG ((LOLOC (I.LOLOC PTR)))
          (\BYTESETA CA (SUB1 BN)
                 (LRSH LOLOC 8))
          (\BYTESETA CA BN (LOGAND LOLOC 255))
          (\BYTESETA CA (IDIFFERENCE BN 2)
                 (LOGOR (\BYTELT CA (IDIFFERENCE BN 2))
                        (I.HILOC PTR])
-
-(I.FIXUPSYM
  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited 23-Jan-91 19:04 by jds")

    (* ;; "�2�Perform SYMBOL fixup for a code block.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)

        (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.")

        (I.FIXUPPTR CA BN (I.ATOMNUMBER NUM)))
       (T 
          (* ;; "Otherwise, fill in the two bytes.")

          (\BYTESETA CA (SUB1 BN)
                 (LOGOR (LOGAND (\BYTELT CA (SUB1 BN))
                               (LRSH (LOGXOR MASK 65535)
                                     8))
                        (LOGAND (LRSH (LOGAND (I.ATOMNUMBER NUM)
                                             MASK)
                                      8)
                               255)))
          (\BYTESETA CA BN (LOGAND (I.ATOMNUMBER NUM)
                                  255])
-
-(I.WORDSPERNAMEENTRY
  [LAMBDA NIL                                            (* ; "Edited 25-Jan-91 15:35 by jds")

    (* ;; "For MAKEINIT, returns the number of words in a name-table entry.")

    (* ;; "For the old 2-byte atom case, it's 1 word; for 3-byte atoms, 2 words.")

    (* ;; "An %"Entry%" means an entry in each half of the name table (symbol & type/offset).")

    (* ;; "While we're building the INIT, react to either :3-BYTE or :3-BYTE-INIT in the target architecture -- we're automatically CROSSCOMPILING as far as this function is concerned.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
        2)
       ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*)
        2)
       (T 1])
-
-(I.SETSTKNTOFFSET
  [LAMBDA (BASE OFFSET TYPE VAL)                         (* ; "Edited 25-Jan-91 16:00 by jds")

    (* ;; "FOR MAKEINIT:  Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
        (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD)
               TYPE)
        (I.FIXUPNUM BASE OFFSET VAL))
       ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*)
        (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD)
               TYPE)
        (I.FIXUPNUM BASE OFFSET VAL))
       (T (I.FIXUPNUM BASE OFFSET (IPLUS TYPE VAL])
-)
-
-
-
-(* ; "stuff for MAXC")
-
-(DEFINEQ
-
-(MKI.ATOM
(LAMBDA (X) (* lmm "29-JUL-81 22:46") (* ; "for MAXC") (AND X (OR (GETHASH X MKI.ATOMARRAY) (PUTHASH X (COND ((EQ X (QUOTE NOBIND)) PTRNOBIND) (T (I.COPYATOM X))) MKI.ATOMARRAY))))
)
-
-(MKI.IEEE
(LAMBDA (X BOX) (* bvm%: "16-Dec-80 00:44") (* ;; "Converts pdp-10 floating-point number X to IEEE standard for Dolphin, storing (with I.PUTBASE) into BOX.  For MAXC only.") (PROG (MAGNITUDE (SIGN 0) (EXP 0) (FRAC 0)) RETRY (SETQ MAGNITUDE (COND ((MINUSP X) (SETQ SIGN 32768) (IMINUS (OPENR (LOC X)))) (T (OPENR (LOC X))))) (COND ((ZEROP MAGNITUDE) (GO DONE)) ((IEQP (LOGAND MAGNITUDE 67108864) 0) (* ; "unnormalized number???") (SETQ X (FPLUS X 0.0)) (GO RETRY))) (COND ((ILEQ (SETQ EXP (IDIFFERENCE (LRSH MAGNITUDE 27) 2)) 0) (* ;; "Exponent bias is off by 1, plus another 1 because of the implicit high bit.  Thus have to watch for underflow") (ERROR "Unrepresentable floating-point number" X) (SETQ EXP (SETQ SIGN 0)) (* ; "If continued, make it zero") (GO DONE))) (SETQ FRAC (IPLUS (LOGAND (LRSH MAGNITUDE 3) 16777215) (COND ((OR (ILESSP (LOGAND MAGNITUDE 7) 4) (EQ (LOGAND MAGNITUDE 15) 4)) (* ; "Round down") 0) (T 1)))) (COND ((IGREATERP FRAC 16777215) (* ; "Rounding overflowed the high bit") (SETQ FRAC (LRSH FRAC 1)) (* ; "EXP can't overflow, because of bias difference") (SETQ EXP (ADD1 EXP)))) (* ; "FRAC is now a 24-bit fraction with its high bit on") DONE (I.PUTBASE BOX 0 (LOGOR SIGN (LLSH EXP 7) (LOGAND (LRSH FRAC 16) 127))) (I.PUTBASE BOX 1 (LOGAND FRAC 65535))))
)
-)
-
-
-
-(* ; "stuff to maintain symbol values, prop lists during makeinit--all dumped at end.")
-
-(DEFINEQ
-
-(MKI.DSET
(LAMBDA (A VAL) (* ; "Edited 12-Jan-88 11:03 by bvm") (LET ((LST (GETHASH A MKI.TVHA))) (COND (LST (COND ((NOT (EQUAL VAL (CDR LST))) (EXEC-FORMAT "(Value of ~S changed from ~S to ~S)~%%" A (CDR LST) VAL))) (RPLACD LST VAL)) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA)))))
)
-
-(MKI.ADDTO
(LAMBDA (A VAL) (* lpd%: "29-APR-77 13:20") (PROG ((LST (GETHASH A MKI.TVHA))) (COND (LST (RPLACD LST (UNION VAL (CDR LST)))) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA)))))
)
-
-(MKI.PUTPROP
(LAMBDA (A PROP VAL) (* ; "Edited 12-Jan-88 11:04 by bvm") (LET ((LST (GETHASH A MKI.PLHA))) (COND (LST (COND ((LISTGET LST PROP) (EXEC-FORMAT "(Property ~S of ~S has been changed)~%%" A PROP))) (LISTPUT LST PROP VAL)) (T (PUTHASH A (LIST PROP VAL) MKI.PLHA)))))
)
-)
-
-(RPAQQ MKI.ARRAY NIL)
-
-(RPAQ MKI.TVHA (HASHARRAY 400))
-
-(RPAQ MKI.PLHA (HASHARRAY 150))
-
-(RPAQ MKI.ATOMARRAY (HASHARRAY 5000))
-
-(RPAQQ INIT.EXT SYSOUT)
-(DEFINEQ
-
-(DUMPVP
(LAMBDA (VP) (* lpd%: "27-APR-77 20:24") (PRIN1 (QUOTE *) T) (WriteoutPage OUTX VP)))
-
-(BOUTZEROS
(LAMBDA (N) (* lmm "16-MAY-81 16:49") (FRPTQ N (\BOUT OUTX 0))))
-
-(BIN16
(LAMBDA (J) (* lmm "16-MAY-81 16:49") (IPLUS (LLSH (\BIN J) 8) (\BIN J))))
-
-(BOUT16
(LAMBDA (J N) (* lmm "16-MAY-81 16:51") (\BOUT J (LRSH N 8)) (\BOUT J (LOGAND N 255))))
-)
-
-(RPAQQ MKI.FirstDataByte 1024)
-
-(RPAQQ MKI.Page0Byte 512)
-
-(RPAQ MKI.DATE (DATE))
-
-(RPAQQ MKI.CODESTARTOFFSET 60)
-
-(RPAQQ MKI.SEQUENTIAL ((SEQUENTIAL T)))
-
-(RPAQQ PRINTEXPRS T)
-
-(RPAQ? PRINTEXPRS T)
-
-(RPAQ? REMOTECOMPILE.EXT COMPILE.EXT)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(PUTPROP (NAMEFIELD (INPUT)
-                T)
-       'LOADDATE
-       (GETFILEINFO (INPUT)
-              'ICREATIONDATE))
-)
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS SETXVAR MACRO [X `(SETQ.NOREF %, (CADAR X)
-                                       %,
-                                       (CADR X])
-
-(PUTPROPS IEQ MACRO ((X Y)
-                         (IEQP X Y)))
-DONTCOPY 
-
-(FILESLOAD (LOADCOMP)
-       MEM)
-)
-(PUTPROPS MAKEINIT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991
- 1992 1998))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (2691 9683 (LOADMAKEINIT 2701 . 3904) (LOADMKIFILES 3906 . 4126) (RELOAD 4128 . 4611) (
-MAKEINIT 4613 . 8975) (MKI.START 8977 . 9681)) (9761 13662 (MKI.PASSFILE 9771 . 11564) (SCRATCHARRAY 
-11566 . 12215) (DOFORM 12217 . 12894) (CONSTFORMP 12896 . 13130) (NOTICECOMS 13132 . 13440) (
-EVALFORMAKEINIT 13442 . 13660)) (13663 15783 (I.ADDTOVAR 13673 . 13767) (I.DECLARE%: 13769 . 14045) (
-I.DEFINE-FILE-INFO 14047 . 14237) (I.FILECREATED 14239 . 14613) (I.PUTPROPS 14615 . 14728) (I.RPAQ 
-14730 . 14951) (I.RPAQQ 14953 . 15149) (I.RPAQ? 15151 . 15366) (I.SETTOPVAL 15368 . 15600) (I.NOUNDO 
-15602 . 15781)) (16359 22359 (I.ATOMNUMBER 16369 . 16860) (I.\ATOMCELL 16862 . 18615) (I.FIXUPNUM 
-18617 . 19434) (I.FIXUPPTR 19436 . 19917) (I.FIXUPSYM 19919 . 20867) (I.WORDSPERNAMEENTRY 20869 . 
-21624) (I.SETSTKNTOFFSET 21626 . 22357)) (22391 23899 (MKI.ATOM 22401 . 22597) (MKI.IEEE 22599 . 23897
-)) (23996 24761 (MKI.DSET 24006 . 24289) (MKI.ADDTO 24291 . 24476) (MKI.PUTPROP 24478 . 24759)) (24935
- 25313 (DUMPVP 24945 . 25042) (BOUTZEROS 25044 . 25123) (BIN16 25125 . 25210) (BOUT16 25212 . 25311)))
-))
-STOP
+                    (I.ADDBASE ATOMNO OFFSET])

(I.FIXUPNUM
  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited 17-Jul-90 14:28 by jds")

    (* ;; "�2�Perform atom-number fixup for a code block.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)

        (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.")

        (I.FIXUPPTR CA BN NUM))
       (T 
          (* ;; "Otherwise, fill in the two bytes.")

          (\BYTESETA CA (SUB1 BN)
                 (LOGOR (LOGAND (\BYTELT CA (SUB1 BN))
                               (LRSH (LOGXOR MASK 65535)
                                     8))
                        (LOGAND (LRSH (LOGAND NUM MASK)
                                      8)
                               255)))
          (\BYTESETA CA BN (LOGAND NUM 255])

(I.FIXUPPTR
  [LAMBDA (CA BN PTR)                                    (* ; "Edited 22-Jul-90 12:10 by jds")

    (* ;; "Specific for MAXC --- actual ptr is same as simulated ptr")

    (PROG ((LOLOC (I.LOLOC PTR)))
          (\BYTESETA CA (SUB1 BN)
                 (LRSH LOLOC 8))
          (\BYTESETA CA BN (LOGAND LOLOC 255))
          (\BYTESETA CA (IDIFFERENCE BN 2)
                 (LOGOR (\BYTELT CA (IDIFFERENCE BN 2))
                        (I.HILOC PTR])

(I.FIXUPSYM
  [LAMBDA (CA BN NUM MASK)                               (* ; "Edited 23-Jan-91 19:04 by jds")

    (* ;; "�2�Perform SYMBOL fixup for a code block.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)

        (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.")

        (I.FIXUPPTR CA BN (I.ATOMNUMBER NUM)))
       (T 
          (* ;; "Otherwise, fill in the two bytes.")

          (\BYTESETA CA (SUB1 BN)
                 (LOGOR (LOGAND (\BYTELT CA (SUB1 BN))
                               (LRSH (LOGXOR MASK 65535)
                                     8))
                        (LOGAND (LRSH (LOGAND (I.ATOMNUMBER NUM)
                                             MASK)
                                      8)
                               255)))
          (\BYTESETA CA BN (LOGAND (I.ATOMNUMBER NUM)
                                  255])

(I.WORDSPERNAMEENTRY
  [LAMBDA NIL                                            (* ; "Edited 25-Jan-91 15:35 by jds")

    (* ;; "For MAKEINIT, returns the number of words in a name-table entry.")

    (* ;; "For the old 2-byte atom case, it's 1 word; for 3-byte atoms, 2 words.")

    (* ;; "An %"Entry%" means an entry in each half of the name table (symbol & type/offset).")

    (* ;; "While we're building the INIT, react to either :3-BYTE or :3-BYTE-INIT in the target architecture -- we're automatically CROSSCOMPILING as far as this function is concerned.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
        2)
       ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*)
        2)
       (T 1])

(I.SETSTKNTOFFSET
  [LAMBDA (BASE OFFSET TYPE VAL)                         (* ; "Edited 25-Jan-91 16:00 by jds")

    (* ;; "FOR MAKEINIT:  Set the offset entry for a name-table entry, from the symbol to fill in plus the variable-type marker value SHIFTED LEFT 14 BITS ALREADY.")

    (COND
       ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*)
        (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD)
               TYPE)
        (I.FIXUPNUM BASE OFFSET VAL))
       ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*)
        (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD)
               TYPE)
        (I.FIXUPNUM BASE OFFSET VAL))
       (T (I.FIXUPNUM BASE OFFSET (IPLUS TYPE VAL])
)



(* ; "stuff for MAXC")

(DEFINEQ

(MKI.ATOM
(LAMBDA (X) (* lmm "29-JUL-81 22:46") (* ; "for MAXC") (AND X (OR (GETHASH X MKI.ATOMARRAY) (PUTHASH X (COND ((EQ X (QUOTE NOBIND)) PTRNOBIND) (T (I.COPYATOM X))) MKI.ATOMARRAY))))
)

(MKI.IEEE
(LAMBDA (X BOX) (* bvm%: "16-Dec-80 00:44") (* ;; "Converts pdp-10 floating-point number X to IEEE standard for Dolphin, storing (with I.PUTBASE) into BOX.  For MAXC only.") (PROG (MAGNITUDE (SIGN 0) (EXP 0) (FRAC 0)) RETRY (SETQ MAGNITUDE (COND ((MINUSP X) (SETQ SIGN 32768) (IMINUS (OPENR (LOC X)))) (T (OPENR (LOC X))))) (COND ((ZEROP MAGNITUDE) (GO DONE)) ((IEQP (LOGAND MAGNITUDE 67108864) 0) (* ; "unnormalized number???") (SETQ X (FPLUS X 0.0)) (GO RETRY))) (COND ((ILEQ (SETQ EXP (IDIFFERENCE (LRSH MAGNITUDE 27) 2)) 0) (* ;; "Exponent bias is off by 1, plus another 1 because of the implicit high bit.  Thus have to watch for underflow") (ERROR "Unrepresentable floating-point number" X) (SETQ EXP (SETQ SIGN 0)) (* ; "If continued, make it zero") (GO DONE))) (SETQ FRAC (IPLUS (LOGAND (LRSH MAGNITUDE 3) 16777215) (COND ((OR (ILESSP (LOGAND MAGNITUDE 7) 4) (EQ (LOGAND MAGNITUDE 15) 4)) (* ; "Round down") 0) (T 1)))) (COND ((IGREATERP FRAC 16777215) (* ; "Rounding overflowed the high bit") (SETQ FRAC (LRSH FRAC 1)) (* ; "EXP can't overflow, because of bias difference") (SETQ EXP (ADD1 EXP)))) (* ; "FRAC is now a 24-bit fraction with its high bit on") DONE (I.PUTBASE BOX 0 (LOGOR SIGN (LLSH EXP 7) (LOGAND (LRSH FRAC 16) 127))) (I.PUTBASE BOX 1 (LOGAND FRAC 65535))))
)
)



(* ; "stuff to maintain symbol values, prop lists during makeinit--all dumped at end.")

(DEFINEQ

(MKI.DSET
(LAMBDA (A VAL) (* ; "Edited 12-Jan-88 11:03 by bvm") (LET ((LST (GETHASH A MKI.TVHA))) (COND (LST (COND ((NOT (EQUAL VAL (CDR LST))) (EXEC-FORMAT "(Value of ~S changed from ~S to ~S)~%%" A (CDR LST) VAL))) (RPLACD LST VAL)) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA)))))
)

(MKI.ADDTO
(LAMBDA (A VAL) (* lpd%: "29-APR-77 13:20") (PROG ((LST (GETHASH A MKI.TVHA))) (COND (LST (RPLACD LST (UNION VAL (CDR LST)))) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA)))))
)

(MKI.PUTPROP
(LAMBDA (A PROP VAL) (* ; "Edited 12-Jan-88 11:04 by bvm") (LET ((LST (GETHASH A MKI.PLHA))) (COND (LST (COND ((LISTGET LST PROP) (EXEC-FORMAT "(Property ~S of ~S has been changed)~%%" A PROP))) (LISTPUT LST PROP VAL)) (T (PUTHASH A (LIST PROP VAL) MKI.PLHA)))))
)
)

(RPAQQ MKI.ARRAY NIL)

(RPAQ MKI.TVHA (HASHARRAY 400))

(RPAQ MKI.PLHA (HASHARRAY 150))

(RPAQ MKI.ATOMARRAY (HASHARRAY 5000))

(RPAQQ INIT.EXT SYSOUT)
(DEFINEQ

(DUMPVP
(LAMBDA (VP) (* lpd%: "27-APR-77 20:24") (PRIN1 (QUOTE *) T) (WriteoutPage OUTX VP)))

(BOUTZEROS
(LAMBDA (N) (* lmm "16-MAY-81 16:49") (FRPTQ N (\BOUT OUTX 0))))

(BIN16
(LAMBDA (J) (* lmm "16-MAY-81 16:49") (IPLUS (LLSH (\BIN J) 8) (\BIN J))))

(BOUT16
(LAMBDA (J N) (* lmm "16-MAY-81 16:51") (\BOUT J (LRSH N 8)) (\BOUT J (LOGAND N 255))))
)

(RPAQQ MKI.FirstDataByte 1024)

(RPAQQ MKI.Page0Byte 512)

(RPAQ MKI.DATE (DATE))

(RPAQQ MKI.CODESTARTOFFSET 60)

(RPAQQ MKI.SEQUENTIAL ((SEQUENTIAL T)))

(RPAQQ PRINTEXPRS T)

(RPAQ? PRINTEXPRS T)

(RPAQ? REMOTECOMPILE.EXT COMPILE.EXT)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(PUTPROP (NAMEFIELD (INPUT)
                T)
       'LOADDATE
       (GETFILEINFO (INPUT)
              'ICREATIONDATE))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS SETXVAR MACRO [X `(SETQ.NOREF %, (CADAR X)
                                           %,
                                           (CADR X])

(PUTPROPS IEQ MACRO ((X Y)
                             (IEQP X Y)))
DONTCOPY 

(FILESLOAD (LOADCOMP)
       MEM)
)
(PUTPROPS MAKEINIT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991
 1992 1998 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2735 9120 (LOADMAKEINIT 2745 . 3948) (LOADMKIFILES 3950 . 4265) (RELOAD 4267 . 4750) (
MAKEINIT 4752 . 8412) (MKI.START 8414 . 9118)) (9198 13099 (MKI.PASSFILE 9208 . 11001) (SCRATCHARRAY 
11003 . 11652) (DOFORM 11654 . 12331) (CONSTFORMP 12333 . 12567) (NOTICECOMS 12569 . 12877) (
EVALFORMAKEINIT 12879 . 13097)) (13100 15220 (I.ADDTOVAR 13110 . 13204) (I.DECLARE%: 13206 . 13482) (
I.DEFINE-FILE-INFO 13484 . 13674) (I.FILECREATED 13676 . 14050) (I.PUTPROPS 14052 . 14165) (I.RPAQ 
14167 . 14388) (I.RPAQQ 14390 . 14586) (I.RPAQ? 14588 . 14803) (I.SETTOPVAL 14805 . 15037) (I.NOUNDO 
15039 . 15218)) (15856 21856 (I.ATOMNUMBER 15866 . 16357) (I.\ATOMCELL 16359 . 18112) (I.FIXUPNUM 
18114 . 18931) (I.FIXUPPTR 18933 . 19414) (I.FIXUPSYM 19416 . 20364) (I.WORDSPERNAMEENTRY 20366 . 
21121) (I.SETSTKNTOFFSET 21123 . 21854)) (21888 23396 (MKI.ATOM 21898 . 22094) (MKI.IEEE 22096 . 23394
)) (23493 24258 (MKI.DSET 23503 . 23786) (MKI.ADDTO 23788 . 23973) (MKI.PUTPROP 23975 . 24256)) (24432
 24810 (DUMPVP 24442 . 24539) (BOUTZEROS 24541 . 24620) (BIN16 24622 . 24707) (BOUT16 24709 . 24808)))
))
STOP
\ No newline at end of file
diff --git a/sources/MAKEINIT.LCOM.~9~ b/sources/MAKEINIT.LCOM
old mode 100644
new mode 100755
similarity index 84%
rename from sources/MAKEINIT.LCOM.~9~
rename to sources/MAKEINIT.LCOM
index 78c18b63..eaa990f6
Binary files a/sources/MAKEINIT.LCOM.~9~ and b/sources/MAKEINIT.LCOM 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/sources/MAKEINITGREET b/sources/MAKEINITGREET
new file mode 100644
index 00000000..161679f1
--- /dev/null
+++ b/sources/MAKEINITGREET
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "14-Feb-2021 09:57:01" {DSK}<home>larry>ilisp>medley>sources>MAKEINITGREET.;2 1770   

      changes to%:  (FNS MAKEINITGREET)

      previous date%: " 7-Feb-2021 18:10:42" {DSK}<home>larry>ilisp>medley>sources>MAKEINITGREET.;1
)


(PRETTYCOMPRINT MAKEINITGREETCOMS)

(RPAQQ MAKEINITGREETCOMS ((FNS MAKEINITGREET)
                              (FILES (SOURCE)
                                     FILESETS)
                              (FILES RENAMEFNS MAKEINIT DLFIXINIT XCL-PACKAGE CMLARRAY-SUPPORT VMEM)))
(DEFINEQ

(MAKEINITGREET
  [LAMBDA NIL                                          (* ; "Edited 14-Feb-2021 09:56 by larry")
                                                            (* ; "Edited  5-Dec-2017 15:26 by rmk:")

    (* ;; "")

    (* ;; " Updated Lisp version for big physical memory --bvm |11/3/87")

    (* ;; "")

    (XCL:RESTORE-PROFILE "INTERLISP")                        (* ; "Doesn't exist")
    (SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)
    (SETQ *REMOVE-INTERLISP-COMMENTS* NIL)
    (LOAD 'FILESETS)                                         (* ; "rmk: VMEM has WORDARRAY")
                                                             (* Versions are Lisp Microcode Bcpl)
    (BKSYSBUF " ")
    (DORENAME 'I)
    (DLFIXINIT (MAKEINIT '(39424 5682 11008)
                      (MEDLEYDIR "loadups" "init.sysout" T)
                      NIL DIRECTORIES DISPLAYFONTDIRECTORIES)
           (MEDLEYDIR "loadups" "init.dlinit" T])
)

(FILESLOAD (SOURCE)
       FILESETS)

(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT XCL-PACKAGE CMLARRAY-SUPPORT VMEM)
(PUTPROPS MAKEINITGREET COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (596 1591 (MAKEINITGREET 606 . 1589)))))
STOP
\ No newline at end of file
diff --git a/sources/MAKEINITGREET.LCOM b/sources/MAKEINITGREET.LCOM
new file mode 100644
index 00000000..f7a020b6
Binary files /dev/null and b/sources/MAKEINITGREET.LCOM differ
diff --git a/sources/XREM.CM b/sources/XREM.CM
new file mode 100644
index 00000000..19245020
--- /dev/null
+++ b/sources/XREM.CM
@@ -0,0 +1,8 @@
+"
+(SETQ SI::*CLOSURE-CACHE-ENABLED* NIL)
+(QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT* ))
+(MOVD? (QUOTE NILL) (QUOTE PROMPTPRINT))
+(MOVD? (QUOTE NILL) (QUOTE CURSORP))
+(MOVD? (QUOTE NILL) (QUOTE CHANGEBACKGROUNDBORDER))
+(LOGOUT)
+"
diff --git a/sources/YREM.CM b/sources/YREM.CM
new file mode 100644
index 00000000..157ca98e
--- /dev/null
+++ b/sources/YREM.CM
@@ -0,0 +1,6 @@
+"
+(PROGN(LOAD(CONCAT (QUOTE {DSK}) (UNIX-GETENV (QUOTE MEDLEYDIR)) (QUOTE /sources/LOADUP.LISP)))(HARDRESET))
+SHH(PROGN(IL:ENDLOADUP)(SETQ IL:MAKESYSNAME ':MEDLEY)(IL:MAKESYS (IL:CONCAT (QUOTE {DSK})(IL:UNIX-GETENV(QUOTE MEDLEYDIR))(IL:L-CASE (QUOTE /loadups/lisp.sysout)))))
+(IL:LOGOUT T)
+
+"
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
