diff --git a/sources/ADIR b/sources/ADIR
index 882e745c..653327eb 100644
--- a/sources/ADIR
+++ b/sources/ADIR
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Mar-2021 14:21:13" {DSK}<home>larry>ilisp>medley>sources>ADIR.;11 61680  

      changes to%:  (FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE OUTFILEP
                         RENAMEFILE SIMPLE.FINDFILE UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS 
                         \UPF.NEXTPOS \UPF.TEMPFILEP FILENAMEFIELD PACKFILENAME PACKFILENAME.STRING 
                         LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT USERNAME 
                         SETUSERNAME)

      previous date%: "15-Mar-2021 12:41:13" {DSK}<home>larry>ilisp>medley>sources>ADIR.;9)


(* ; "
Copyright (c) 1981-1988, 1990-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)                                       (* ; "Edited 15-Mar-2021 11:53 by larry")
    (\USEREVENT 'BEFORELOGOUT)
    (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 15-Mar-2021 12:40 by larry")
                                                             (* ; "Edited 28-Jul-88 18:16 by drc:")
    (\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 (OUTFILEP FILE]
         (COND
            ((NLISTP NEWFILE)                                (* ; 
                               "Coming back from doing the MAKESYS, so just set up to keep going.,")
             (\DEVICEEVENT 'AFTERDOMAKESYS)
             (\USEREVENT 'AFTERDOMAKESYS)
             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 15-Mar-2021 12:17 by larry")
                                                             (* hdj "29-Sep-86 12:14")
    (DECLARE (GLOBALVARS \MISCSTATS)
           (SPECVARS FILE))                                  (* ; 
                                           "FILE is special so that BEFORESYSOUTFORMS can alter it")
    (\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 (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 NIL                                          (* ; "Edited 15-Mar-2021 12:04 by larry")

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

    (\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 15-Mar-2021 12:27 by larry")
    (DECLARE (GLOBALVARS STARTUPFORM))

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

    (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]
             (T (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 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3067 9761 (DELFILE 3077 . 3238) (FULLNAME 3240 . 3607) (INFILE 3609 . 3757) (INFILEP 
3759 . 3894) (IOFILE 3896 . 4036) (OPENFILE 4038 . 4438) (OPENSTREAM 4440 . 8748) (OUTFILE 8750 . 8901
) (OUTFILEP 8903 . 9039) (RENAMEFILE 9041 . 9347) (SIMPLE.FINDFILE 9349 . 9759)) (10133 29724 (
UNPACKFILENAME 10143 . 10329) (UNPACKFILENAME.STRING 10331 . 26603) (LASTCHPOS 26605 . 27299) (
\UPF.NEXTPOS 27301 . 27946) (\UPF.TEMPFILEP 27948 . 28525) (FILENAMEFIELD 28527 . 29012) (PACKFILENAME
 29014 . 29357) (PACKFILENAME.STRING 29359 . 29722)) (52165 59307 (LOGOUT 52175 . 53092) (MAKESYS 
53094 . 54677) (SYSOUT 54679 . 56239) (SAVEVM 56241 . 57041) (HERALD 57043 . 57203) (INTERPRET.REM.CM 
57205 . 58930) (\USEREVENT 58932 . 59305)) (59489 61216 (USERNAME 59499 . 60455) (SETUSERNAME 60457 . 
61214)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "21-Mar-2021 21:59:07" {DSK}<home>larry>ilisp>medley>sources>ADIR.;30 65795  

      changes to%:  (VARS ADIRCOMS)
                    (FNS \FLUSHVM \LOGOUT0)

      previous date%: "16-Mar-2021 19:55:51" {DSK}<home>larry>ilisp>medley>sources>ADIR.;26)


(* ; "
Copyright (c) 1981-1988, 1990-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 VMEMSIZE \COPYSYS \FLUSHVM \LOGOUT0)
              (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])

(VMEMSIZE
  [LAMBDA NIL                                            (* bvm%: " 1-NOV-82 16:44")
    (fetch (IFPAGE NActivePages) of \InterfacePage])

(\COPYSYS
  [LAMBDA (FILE SYSNAME DONTSAVE)                      (* ; "Edited 16-Mar-2021 19:46 by larry")
    (PROG (FULLNAME VAL HOST)
      RETRY
          (SETQ FILE (PACKFILENAME.STRING 'BODY FILE 'BODY "WORK.SYSOUT" 'BODY 
                            \CONNECTED.DIRECTORY))
          [SELECTQ [SETQ HOST (U-CASE (FILENAMEFIELD FILE 'HOST]
              (DSK [SETQ FULLNAME (PACKFILENAME.STRING 'HOST HOST 'EXTENSION "tmpsysout"
                                         'BODY
                                         (\UFS.RECOGNIZE.FILE FILE 'NON (\GETDEVICEFROMNAME HOST]
                   (SETQ VAL (\FLUSHVM FULLNAME))
                   (SETQ FULLNAME (RENAMEFILE FULLNAME FILE)))
              (UNIX [SETQ FULLNAME (CONCAT "{" HOST "}" (\UFS.RECOGNIZE.FILE FILE 'NON (
                                                                                   \GETDEVICEFROMNAME
                                                                                        HOST]
                                                             (* ; "\DOFLUSHVM ")
                    (SETQ VAL (\FLUSHVM FULLNAME)))
              (PROGN (SETQ VAL (\FLUSHVM))
                     (LET ((UNIXVAR (UNIX-GETENV "LDEDESTSYSOUT")))
                                                             (* ; 
                                  "\FLSUVM saves image to  Unix enviroment var  or lisp.virtualmem")
                          (SETQ FULLNAME (COPYFILE (COND
                                                      (UNIXVAR (CONCAT "{DSK}" UNIXVAR))
                                                      (T "{DSK}~/lisp.virtualmem"))
                                                FILE
                                                '((TYPE BINARY]
          (COND
             ((NULL VAL)

              (* ;; "First clause of OR is T when resuming this vmem;  second is starting the sysout.  Unless \COPYSYS1 itself does a \FLUSHVM, the second never returns T, yes?  NIL is normal return (continuing in same image), <fixp> is error return")
                                                             (* ; "Continuing in the current image")
              (\DAYTIME0 \LASTUSERACTION)
              (RETURN FULLNAME))
             ((AND (SMALLP VAL)
                   (IGREATERP 0 VAL))                        (* ; 
                                                           "Error occurred while making sysout.")
              (LISPERROR (IMINUS VAL)
                     FULLNAME)
              (GO RETRY))
             (T                                              (* ; "Starting sysout")
                (\CLEARSYSBUF T)                             (* ; 
                                                           "Get rid of any spurious typeahead")
                (\RESETKEYBOARD)                             (* ; "Enable keyhandler")
                (RETURN (LIST FULLNAME])

(\FLUSHVM
  [LAMBDA (MAIKO.SYSOUTFILE)                           (* ; "Edited 16-Mar-2021 10:59 by larry")
                                                            (* ; "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 (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 21-Mar-2021 21:13 by larry")
    (OR (AND (NOT FAST)
             (\FLUSHVM))
        (SUBRCALL LISPFINISH FAST])
)
(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)                                       (* ; "Edited 15-Mar-2021 11:53 by larry")
    (\USEREVENT 'BEFORELOGOUT)
    (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 16-Mar-2021 19:36 by larry")
                                                             (* ; "Edited 28-Jul-88 18:16 by drc:")
    (\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 LMM unneded -- OUTFILEP assivvns a new version number")

    (LET ((NEWFILE (\COPYSYS FILE)))
         (COND
            ((NLISTP NEWFILE)                                (* ; 
                               "Coming back from doing the MAKESYS, so just set up to keep going.,")
             (\DEVICEEVENT 'AFTERDOMAKESYS)
             (\USEREVENT 'AFTERDOMAKESYS)
             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 16-Mar-2021 19:34 by larry")
                                                             (* hdj "29-Sep-86 12:14")
    (DECLARE (GLOBALVARS \MISCSTATS)
           (SPECVARS FILE))                                  (* ; 
                                           "FILE is special so that BEFORESYSOUTFORMS can alter it")
    (\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 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]
         NEWFILE])

(SAVEVM
  [LAMBDA NIL                                          (* ; "Edited 15-Mar-2021 12:04 by larry")

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

    (\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 15-Mar-2021 12:27 by larry")
    (DECLARE (GLOBALVARS STARTUPFORM))

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

    (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]
             (T (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 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2745 13838 (DELFILE 2755 . 2916) (FULLNAME 2918 . 3285) (INFILE 3287 . 3435) (INFILEP 
3437 . 3572) (IOFILE 3574 . 3714) (OPENFILE 3716 . 4116) (OPENSTREAM 4118 . 8426) (OUTFILE 8428 . 8579
) (OUTFILEP 8581 . 8717) (RENAMEFILE 8719 . 9025) (SIMPLE.FINDFILE 9027 . 9437) (VMEMSIZE 9439 . 9606)
 (\COPYSYS 9608 . 12557) (\FLUSHVM 12559 . 13631) (\LOGOUT0 13633 . 13836)) (14210 33801 (
UNPACKFILENAME 14220 . 14406) (UNPACKFILENAME.STRING 14408 . 30680) (LASTCHPOS 30682 . 31376) (
\UPF.NEXTPOS 31378 . 32023) (\UPF.TEMPFILEP 32025 . 32602) (FILENAMEFIELD 32604 . 33089) (PACKFILENAME
 33091 . 33434) (PACKFILENAME.STRING 33436 . 33799)) (56242 63422 (LOGOUT 56252 . 57169) (MAKESYS 
57171 . 58800) (SYSOUT 58802 . 60354) (SAVEVM 60356 . 61156) (HERALD 61158 . 61318) (INTERPRET.REM.CM 
61320 . 63045) (\USEREVENT 63047 . 63420)) (63604 65331 (USERNAME 63614 . 64570) (SETUSERNAME 64572 . 
65329)))))
STOP
\ No newline at end of file
diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM
index db8cfdcf..48f6ab38 100644
Binary files a/sources/ADIR.LCOM and b/sources/ADIR.LCOM differ
diff --git a/sources/LLFAULT b/sources/LLFAULT
index c5cb6d3d..0f7d8699 100644
--- a/sources/LLFAULT
+++ b/sources/LLFAULT
@@ -1 +1 @@
-(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
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "21-Mar-2021 21:33:01" {DSK}<home>larry>ilisp>medley>sources>LLFAULT.;10 501717Q

      changes to%:  (VARS LLFAULTCOMS)

      previous date%: "16-Mar-2021 20:27:50" {DSK}<home>larry>ilisp>medley>sources>LLFAULT.;8)


(* ; "
Copyright (c) 1982-1993, 2021 by Venue & Xerox Corporation.
")

(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 \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 CHECKPAGEMAP \SHOWPAGETABLE VMEM.PURE.STATE \COUNTREALPAGES 
                            \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \DOTEMPLOCKPAGES 
                            \DOLOCKPAGES \LOCKPAGES \LOADVMEMPAGE])

(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

(\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 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 3745Q))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (31106Q 65232Q (\FAULTINIT 31120Q . 40347Q) (\D01.FAULTINIT 40351Q . 45776Q) (
\D01.ASSIGNBUFFERS 46000Q . 51545Q) (\MAIKO.FAULTINIT 51547Q . 54334Q) (\MAIKO.NEWFAULTINIT 54336Q . 
55672Q) (\MAIKO.ASSIGNBUFFERS 55674Q . 61450Q) (\M-VMEMSAVE 61452Q . 64672Q) (\MAIKO.NEWPAGE 64674Q . 
65230Q)) (65432Q 73060Q (\MAIKO.DO.MOVDS 65444Q . 73056Q)) (74217Q 164677Q (\DOVE.FAULTINIT 74231Q . 
100624Q) (\DL.FAULTINIT 100626Q . 105717Q) (\DL.NEWFAULTINIT 105721Q . 152433Q) (\DL.UNMAPPAGES 
152435Q . 153423Q) (\DL.MARK.PAGES.UNAVAILABLE 153425Q . 154363Q) (\DL.ASSIGNBUFFERS 154365Q . 160106Q
) (\CHAIN.UP.RPT 160110Q . 164675Q)) (164742Q 251155Q (\FAULTHANDLER 164754Q . 165632Q) (\PAGEFAULT 
165634Q . 171373Q) (\INVALIDADDR 171375Q . 171651Q) (\INVALIDVP 171653Q . 172112Q) (\FLUSHPAGE 172114Q
 . 177255Q) (\LOADVMEMPAGE 177257Q . 203331Q) (\MOVEREALPAGE 203333Q . 206573Q) (\LOOKUPPAGEMAP 
206575Q . 207567Q) (\VALIDADDRESSP 207571Q . 210061Q) (\LOCKEDPAGEP 210063Q . 211265Q) (
\SELECTREALPAGE 211267Q . 233224Q) (\SPECIALRP 233226Q . 234243Q) (\TRANSFERPAGE 234245Q . 242106Q) (
\UPDATECHAIN 242110Q . 251153Q)) (251237Q 326030Q (\NEWPAGE 251251Q . 253267Q) (\DONEWPAGE 253271Q . 
263030Q) (\ASSURE.FPTOVP.PAGE 263032Q . 266004Q) (\MAKESPACEFORLOCKEDPAGE 266006Q . 273410Q) (
\MOVEVMEMFILEPAGE 273412Q . 276033Q) (\NEWEPHEMERALPAGE 276035Q . 276566Q) (\DONEWEPHEMERALPAGE 
276570Q . 304006Q) (\LOCKPAGES 304010Q . 304434Q) (\DOLOCKPAGES 304436Q . 314202Q) (\TEMPLOCKPAGES 
314204Q . 314713Q) (\DOTEMPLOCKPAGES 314715Q . 317730Q) (\TEMPUNLOCKPAGES 317732Q . 322614Q) (
\UNLOCKPAGES 322616Q . 326026Q)) (326076Q 350675Q (\DOFLUSHVM 326110Q . 330574Q) (\RELEASEWORKINGSET 
330576Q . 332366Q) (\WRITEDIRTYPAGE 332370Q . 346134Q) (\WRITEDIRTYPAGE1 346136Q . 347463Q) (
\COUNTREALPAGES 347465Q . 350673Q)) (350743Q 354272Q (\DOCOMPRESSVMEM 350755Q . 353273Q) (
VMEM.PURE.STATE 353275Q . 354270Q)) (354541Q 365050Q (32MBADDRESSABLE 354553Q . 355221Q) (
\SET.VMEM.FULL.STATE 355223Q . 357144Q) (\SET.LASTVMEMFILEPAGE 357146Q . 360517Q) (
\DOVMEMFULLINTERRUPT 360521Q . 364264Q) (\FLUSHVMOK? 364266Q . 365046Q)) (366524Q 367160Q (\MP.ERROR 
366536Q . 367156Q)) (367311Q 417121Q (\ACTONVMEMFILE 367323Q . 370122Q) (\SHOWPAGETABLE 370124Q . 
375625Q) (CHECKPAGEMAP 375627Q . 403511Q) (CHECKFPTOVP 403513Q . 404525Q) (CHECKFPTOVP1 404527Q . 
405716Q) (\PRINTFPTOVP 405720Q . 416603Q) (\PRINTVP 416605Q . 417117Q)) (437066Q 466564Q (ADDPME 
437100Q . 442447Q) (CHECKIFPAGE 442451Q . 442723Q) (DUMPINITPAGES 442725Q . 450343Q) (MAKEROOMFORPME 
450345Q . 452045Q) (MAPPAGES 452047Q . 453246Q) (READPAGEMAP 453250Q . 462425Q) (READPAGEMAPBLOCK 
462427Q . 463217Q) (SETUPPAGEMAP 463221Q . 466562Q)) (471673Q 474241Q (\LOCKFN 471705Q . 472410Q) (
\LOCKCODE 472412Q . 472754Q) (\LOCKVAR 472756Q . 473226Q) (\LOCKCELL 473230Q . 473474Q) (\LOCKWORDS 
473476Q . 474237Q)))))
STOP
\ No newline at end of file
diff --git a/sources/LLFAULT.LCOM b/sources/LLFAULT.LCOM
index 4befe3fe..a003e883 100644
Binary files a/sources/LLFAULT.LCOM and b/sources/LLFAULT.LCOM differ
diff --git a/sources/LOADUP-LISP b/sources/LOADUP-LISP
index c05c31bb..9968095a 100644
--- a/sources/LOADUP-LISP
+++ b/sources/LOADUP-LISP
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "12-Mar-2021 12:35:42" |{DSK}<home>larry>ilisp>med>sources>LOADUP-LISP.;4| 8422   

      |changes| |to:|  (FNS LOADUP-LISP)

      |previous| |date:| "12-Mar-2021 10:15:45" |{DSK}<home>larry>ilisp>med>sources>LOADUP-LISP.;3|
)


(PRETTYCOMPRINT LOADUP-LISPCOMS)

(RPAQQ LOADUP-LISPCOMS ((FNS LOADUP-LISP)
                            (FNS 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)))
(DEFINEQ

(LOADUP-LISP
  (LAMBDA NIL                                         (* \; "Edited 12-Mar-2021 12:35 by larry")
    (SETQQ COMPILE.EXT LCOM)                                 (* \; "should be set earlier")
    (DRIBBLE (MEDLEYDIR "tmp" "lisp.dribble" T))
    (FOR X IN BOOTLOADEDFILES DO (CL:UNLESS (MEMB X SYSFILES)
                                                 (PRINTOUT T X " bootloaded" T)
                                                 (SETQ SYSFILES (CONS X SYSFILES))))
    (SETQ BOOTLOADEDFILES NIL)
    (IF (NOT (BOUNDP 'DIRECTORIES))
        THEN (SETQ DIRECTORIES LOADUPDIRECTORIES))

    (* |;;| "following files are really loaded earlier, this call to LOADUP just cleans up")

    (LOADUP '(ACODE MACHINEINDEPENDENT POSTLOADUP))

    (* |;;| "establish all package exports early")

    (LOADUP '(LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE))

    (* |;;| "load FASL loader here, so we can load DFASLs earlier in loadup")

    (LOADUP '(ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD))

    (* |;;| "These are needed by any FASL files")

    (LOADUP '(DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON 
                    CMLSEQMAPPERS CMLPATHNAME CMLFILESYS))

(* |;;;| "* 'FASL files may be loaded after this point' * * *")

    (LOADUP '(CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS))

    (* |;;| "early runtime support for Common Lisp and (temporarily) debugger")

    (LOADUP '(STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS))
    (LOADUP '(COMMON XCLC-RUNTIME CMLTYPES CL-ERROR))
    (LOADUP '(AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS 
                    DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE))

    (* |;;| "needed for makesys")

    (LOADUP '(MOD44IO))                                      (* \; 
                                                        "some needed functions here, should remove")

    (* |;;| "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 '(HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD))
    (LOADUP '(GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE))
    (DWIM 'C)

    (* |;;| "Kernel Common Lisp files")

    (LOADUP '(CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY 
                    CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT 
                    CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES))
    (LOADUP '(PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT))
    (LOADUP '(ADDARITH))
    (LOADUP '(CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW 
                    WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE 
                    CMLARRAYINSPECTOR EDITINTERFACE TTYIN))
    (LOADUP '(BREAK-AND-TRACE))
    (LOADUP '(FASDUMP XCL-COMPILER ADVISE))

    (* |;;| "the bytecompiler and Interlisp compiler interface functions")

    (LOADUP '(DLAP BYTECOMPILER COMPILE))
    (LOADUP '(HARDCOPY LOGOW IDLER ICONW FREEMENU SEDIT))    (* \; "don't want LOGOW ")
    (CLOSEW (LOGOW))
    (MOVD 'NILL 'LOGOW)
    (LOADUP '(DSK UFS UFSCALLC MAIKOBITBLT))
    (LOADUP '(TIME))
    (LOADUP '(BRKDWN))
    (LOADUP '(XCL-EXTRAS))                                   (* 
                                                           "CMLPACKAGE pushes onto INSPECTMACROS")
    (LOADUP '(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 '(CMLSMARTARGS))
    (LOADUP '(IMPLICIT-KEY-HASH CLOSURE-CACHE))

    (* |;;| "Already enabled, but this time fixes tables that weren't defined in the init")

    (PACKAGE-ENABLE)
    (DRIBBLE)
    (SETQ MAKESSNAME ':MEDLEY)))
)
(DEFINEQ

(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 NOERROR)           (* \; "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 NOERROR (INFILEP FILENAME)
                               (ERROR "No such medley file" FILENAME)))
      |else| (OR (DIRECTORYNAME (CONCAT (MEDLEYDIR)
                                           DIRNAME))
                     NOERROR
                     (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)
)
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (758 4802 (LOADUP-LISP 768 . 4800)) (4803 7302 (MEDLEY-INIT-VARS 4813 . 5958) (MEDLEYDIR
 5960 . 7300)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "16-Mar-2021 10:17:58" |{DSK}<home>larry>ilisp>medley>sources>LOADUP-LISP.;6| 8250   

      |changes| |to:|  (FNS LOADUP-LISP)

      |previous| |date:| "12-Mar-2021 12:35:42" |{DSK}<home>larry>ilisp>medley>sources>LOADUP-LISP.;5|
)


(PRETTYCOMPRINT LOADUP-LISPCOMS)

(RPAQQ LOADUP-LISPCOMS ((FNS LOADUP-LISP)
                            (FNS 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)))
(DEFINEQ

(LOADUP-LISP
  (LAMBDA NIL                                         (* \; "Edited 16-Mar-2021 10:17 by larry")
    (SETQQ COMPILE.EXT LCOM)                                 (* \; "should be set earlier")
    (DRIBBLE (MEDLEYDIR "tmp" "lisp.dribble" T))
    (FOR X IN BOOTLOADEDFILES DO (CL:UNLESS (MEMB X SYSFILES)
                                                 (PRINTOUT T X " bootloaded" T)
                                                 (SETQ SYSFILES (CONS X SYSFILES))))
    (SETQ BOOTLOADEDFILES NIL)
    (IF (NOT (BOUNDP 'DIRECTORIES))
        THEN (SETQ DIRECTORIES LOADUPDIRECTORIES))

    (* |;;| "following files are really loaded earlier, this call to LOADUP just cleans up")

    (LOADUP '(ACODE MACHINEINDEPENDENT POSTLOADUP))

    (* |;;| "establish all package exports early")

    (LOADUP '(LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE))

    (* |;;| "load FASL loader here, so we can load DFASLs earlier in loadup")

    (LOADUP '(ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD))

    (* |;;| "These are needed by any FASL files")

    (LOADUP '(DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON 
                    CMLSEQMAPPERS CMLPATHNAME CMLFILESYS))

(* |;;;| "* 'FASL files may be loaded after this point' * * *")

    (LOADUP '(CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS))

    (* |;;| "early runtime support for Common Lisp and (temporarily) debugger")

    (LOADUP '(STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS))
    (LOADUP '(COMMON XCLC-RUNTIME CMLTYPES CL-ERROR))
    (LOADUP '(AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS 
                    DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE))

    (* |;;| "needed for makesys")

    (* |;;| "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 '(HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD))
    (LOADUP '(GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE))
    (DWIM 'C)

    (* |;;| "Kernel Common Lisp files")

    (LOADUP '(CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY 
                    CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT 
                    CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES))
    (LOADUP '(PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT))
    (LOADUP '(ADDARITH))
    (LOADUP '(CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW 
                    WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE 
                    CMLARRAYINSPECTOR EDITINTERFACE TTYIN))
    (LOADUP '(BREAK-AND-TRACE))
    (LOADUP '(FASDUMP XCL-COMPILER ADVISE))

    (* |;;| "the bytecompiler and Interlisp compiler interface functions")

    (LOADUP '(DLAP BYTECOMPILER COMPILE))
    (LOADUP '(HARDCOPY LOGOW IDLER ICONW FREEMENU SEDIT))    (* \; "don't want LOGOW ")
    (CLOSEW (LOGOW))
    (MOVD 'NILL 'LOGOW)
    (LOADUP '(DSK UFS UFSCALLC MAIKOBITBLT))
    (LOADUP '(TIME))
    (LOADUP '(BRKDWN))
    (LOADUP '(XCL-EXTRAS))                                   (* 
                                                           "CMLPACKAGE pushes onto INSPECTMACROS")
    (LOADUP '(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 '(CMLSMARTARGS))
    (LOADUP '(IMPLICIT-KEY-HASH CLOSURE-CACHE))

    (* |;;| "Already enabled, but this time fixes tables that weren't defined in the init")

    (PACKAGE-ENABLE)
    (DRIBBLE)
    (SETQ MAKESSNAME ':MEDLEY)))
)
(DEFINEQ

(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 NOERROR)           (* \; "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 NOERROR (INFILEP FILENAME)
                               (ERROR "No such medley file" FILENAME)))
      |else| (OR (DIRECTORYNAME (CONCAT (MEDLEYDIR)
                                           DIRNAME))
                     NOERROR
                     (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)
)
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (764 4630 (LOADUP-LISP 774 . 4628)) (4631 7130 (MEDLEY-INIT-VARS 4641 . 5786) (MEDLEYDIR
 5788 . 7128)))))
STOP
\ No newline at end of file
diff --git a/sources/LOADUP-LISP.LCOM b/sources/LOADUP-LISP.LCOM
index 20f5cb78..4b5f92ec 100644
Binary files a/sources/LOADUP-LISP.LCOM and b/sources/LOADUP-LISP.LCOM differ
diff --git a/sources/MOD44IO b/sources/MOD44IO
index c89b0672..04e34022 100644
--- a/sources/MOD44IO
+++ b/sources/MOD44IO
@@ -1 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "21-Jan-91 23:56:42" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>MOD44IO.;4| 143621 

      changes to%:  (VARS MOD44IOCOMS)
                    (FNS \M44AddDiskPages \M44CompleteFH \M44CREATEFILE \M44DeleteFile \M44EVENTFN 
                         \M44ExtendFilePageMap \M44FillInMap \M44GetFileHandle \M44GetFileInfo 
                         \M44GetFileName \M44GetPageLoc \M44KillFilePageMap \M44MAKEDIRENTRY 
                         \M44OpenFile \M44OPENFILEFROMFP \M44ReadDiskPage \M44ReadLeaderPage 
                         \M44SetAccessTimes \M44SetEndOfFile \M44SetFileInfo \M44SETFILETYPE 
                         \M44TruncateFile \M44WriteDiskPage \M44WriteLeaderPage \M44WritePages 
                         \M44WritePages1 \ADDDISKPAGES \M44DELETEPAGES \ASSIGNDISKPAGE 
                         \M44FLUSHDISKDESCRIPTOR \MAKELEADERDAS \M44GENERATENEXT \M44NEXTFILEFN 
                         \M44SORTEDNEXTFILEFN \M44FILEINFOFN \M44PARSEFILENAME \FINDDIRHOLE 
                         \OPENDISKDESCRIPTOR \M44READDIRFID \M44SEARCHDIR \M44UNPACKFILENAME 
                         \CREATE.FID.FOR.DD \OPENDISK \OPENDISKDEVICE GATHERSTATS)

      previous date%: "16-May-90 20:44:00" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>MOD44IO.;3|)


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

(PRETTYCOMPRINT MOD44IOCOMS)

(RPAQQ MOD44IOCOMS
       (

(* ;;; "Dorado disk driver")

        (COMS 
              (* ;; "Device dependent code for the Model44 disk")

              (FNS \M44AddDiskPages \M44CloseFile \M44CompleteFH \M44CREATEFILE \M44DeleteFile 
                   \M44EVENTFN \M44ExtendFilePageMap \M44FillInMap \M44GetFileHandle \M44GetFileInfo
                   \M44GETDATEPROP \M44GetFileName \M44GetPageLoc \M44KillFilePageMap 
                   \M44MAKEDIRENTRY \M44OpenFile \M44OPENFILEFROMFP \M44ReadDiskPage 
                   \M44ReadLeaderPage \M44ReadPages \M44SetAccessTimes \M44SetEndOfFile 
                   \M44SetFileInfo \M44SETFILETYPE \M44TruncateFile \M44WriteDiskPage 
                   \M44WriteLeaderPage \M44WritePages \M44WritePages1))
        (COMS 
              (* ;; "Disk allocation")

              (FNS \ADDDISKPAGES \M44DELETEPAGES \ASSIGNDISKPAGE \COUNTDISKFREEPAGES \M44MARKPAGEFREE
                   \M44FLUSHDISKDESCRIPTOR \MAKELEADERDAS DISKFREEPAGES \M44FREEPAGECOUNT VMEMSIZE))
        (COMS (INITVARS (\M44MULTFLG T))
              (DECLARE%: DONTCOPY (MACROS UCASECHAR UPDATEVALIDATION)
                     (RECORDS M44DEVICE)
                     (GLOBALVARS \OPENFILES \M44MULTFLG \DISKNAMECASEARRAY)
                     (MACROS .LISP.TO.BFS. .BFS.TO.LISP. .DISKCASEARRAY.)
                     (CONSTANTS (PageMapIncrement 64)
                            (\MAX.ALTO.NAME.LENGTH 39))
                     (COMS 
                           (* ;; "File properties")

                           (RECORDS M44FILEPROP)
                           (CONSTANTS * FPROPTYPES)
                           (CONSTANTS * FPTYPES))
                     (GLOBALRESOURCES \M44PAGEBUFFER))
              (INITRESOURCES \M44PAGEBUFFER))
        (COMS 
              (* ;; "Directory enumeration")

              (FNS \M44GENERATEFILES \M44SORTFILES \M44GENERATENEXT \M44NEXTFILEFN 
                   \M44SORTEDNEXTFILEFN \M44FILEINFOFN))
        (COMS 
              (* ;; "Directory lookup routines")

              (FNS \M44PARSEFILENAME \FINDDIRHOLE \M44PACKFILENAME \M44READVERSION 
                   \OPENDISKDESCRIPTOR \M44READDIRFID \M44READDIRNAME \M44SEARCHDIR 
                   \M44UNPACKFILENAME)
              (VARS \FILENAMECHARSLST)
              (GLOBALVARS \FILENAMECHARSLST)
              (DECLARE%: DONTCOPY (RECORDS UNAME FILESPEC M44GENFILESTATE M44DIRSEARCHSTATE)
                     (MACROS BETWEEN)))
        (COMS (FNS \CREATE.FID.FOR.DD \OPENDISK \OPENDISKDEVICE \OPENDIR \M44CHECKPASSWORD 
                   \M44HOSTNAMEP)
              (DECLARE%: DONTCOPY (CONSTANTS \OFFSET.BCPLUSERNAME \OFFSET.BCPLPASSWORD 
                                         \NWORDS.BCPLPASSWORD)))
        [COMS 
              (* ;; "SYSOUT etc.")

              (FNS \COPYSYS \COPYSYS1)
              
              (* ;; "For MAIKO. \COPYSYS use UNIX-PAGEPERBLOCK.")

              (FNS \MAIKO.CHECKFREESPACE)
              (INITVARS (\LDEDESTOVERWRITE NIL))
              (DECLARE%: DONTCOPY (CONSTANTS (LISPPAGE-PER-UNIXBLOCK 2]
        (COMS 
              (* ;; "Stats code.  On MOD44IO because it writes on the disk and uses records not exported from MOD44IO.  (For this and other reasons, GATHERSTATS only works on Dorados.)")

              (FNS GATHERSTATS)
              (VARS (\STATSON NIL)))
        (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T)
               (FILES (LOADCOMP)
                      LLBFS))))



(* ;;; "Dorado disk driver")




(* ;; "Device dependent code for the Model44 disk")

(DEFINEQ

(\M44AddDiskPages
  [LAMBDA (STREAM NEWLASTPAGE NEWLASTBYTE)               (* ; "Edited 21-Jan-91 23:35 by jds")

    (* ;; "Add pages to an existing Model44 file.  NEWLASTPAGE is the page number of the last page in the extended file.  Return the disk address of the new last page.")

    (\M44FillInMap STREAM (fetch (M44STREAM LastPage) of STREAM))
                                                             (* ; 
                     "Fill in map to end of file.  Code below assumes at least one valid map entry")
    (\ADDDISKPAGES STREAM (ADD1 (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
           (IDIFFERENCE NEWLASTPAGE (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
           (fetch (ARRAYP BASE) of (\M44ExtendFilePageMap STREAM NEWLASTPAGE))
           NEWLASTBYTE)
    (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with NEWLASTPAGE)
    (replace (M44STREAM LastPage) of STREAM with NEWLASTPAGE)
    (replace (M44STREAM LastOffset) of STREAM with NEWLASTBYTE)
                                                             (* ; 
                                                           "record new eof in filehandle only")
    NEWLASTPAGE])

(\M44CloseFile
(LAMBDA (STREAM) (* hdj "25-Sep-86 11:03") (\CLEARMAP STREAM) (COND ((NEQ (fetch ACCESS of STREAM) (QUOTE INPUT)) (* ; "Update EOF in leader page") (\M44TruncateFile STREAM (fetch EPAGE of STREAM) (fetch EOFFSET of STREAM) T) (\M44FLUSHDISKDESCRIPTOR (fetch DEVICE of STREAM)))) STREAM)
)

(\M44CompleteFH
  [LAMBDA (STREAM)                                       (* ; "Edited 21-Jan-91 23:41 by jds")

    (* ;; "Completes the fields of a file handle that describes an existing file by reading in its leader page which it leaves for its caller")

    (PROG ((NUMCHARS (CONS))
           (LEADERPAGE (\M44ReadLeaderPage STREAM))
           (DSK (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)))
           LASTPAGE# NBYTES)

     (* ;; "Get the page number and the number of bytes on the last page of the file specified by fHandle.  If the last page number hint is wrong in the leader page, then find the real last page and change the hint.")

          (COND
             ((AND (NEQ (SETQ LASTPAGE# (.BFS.TO.LISP. (fetch (\M44LeaderPage LastPageNumber)
                                                          of LEADERPAGE)))
                        -1)
                   (EQ [PROG ((DAs (ARRAY 3 'WORD \FILLINDA 0))
                              (BFSPG# (.LISP.TO.BFS. LASTPAGE#)))
                             (SETA DAs 1 (fetch (\M44LeaderPage LastPageAddress) of 
                                                                                           LEADERPAGE
                                                ))
                             (SETA DAs 2 \EOFDA)
                             (RETURN (AND (EQ (\ACTONDISKPAGES DSK NIL (fetch (ARRAYP BASE)
                                                                          of DAs)
                                                     LASTPAGE# STREAM BFSPG# BFSPG# \DC.READD 
                                                     NUMCHARS NIL T)
                                              BFSPG#)
                                          (SETQ NBYTES (CAR NUMCHARS]
                       (fetch (\M44LeaderPage LastPageByteCount) of LEADERPAGE)))
              (replace (M44STREAM LastPage) of STREAM with LASTPAGE#)
                                                             (* ; "Update STREAM eof")
              (replace (M44STREAM LastOffset) of STREAM with NBYTES))
             (T                                              (* ; 
                                                    "Hint was wrong so scan the file for last page")
                (for PN from PageMapIncrement by PageMapIncrement
                   do (SETQ LASTPAGE# (\M44FillInMap STREAM PN)) 
                                                             (* ; 
                                                           "Wait until attempt to find page fails")
                   repeatwhile (EQ PN LASTPAGE#))
                (SETQ NBYTES (\ACTONDISKPAGES DSK NIL (fetch (ARRAYP BASE)
                                                         of (fetch (M44STREAM FILEPAGEMAP)
                                                                   of STREAM))
                                    -1 STREAM (.LISP.TO.BFS. LASTPAGE#)
                                    (.LISP.TO.BFS. LASTPAGE#)
                                    \DC.READD NUMCHARS))     (* ; 
                                              "Read last page to find out how many bytes are on it")
                (\M44SetEndOfFile STREAM LASTPAGE# (CAR NUMCHARS)
                       T)))
          (UPDATEVALIDATION STREAM LEADERPAGE)               (* ; 
                                         "Validation is low order bits of creation and write dates")
          [COND
             ((EQ (fetch (M44STREAM LastOffset) of STREAM)
                  BYTESPERPAGE)

              (* ;; "Shouldn't happen, because alto files should never have a full last page.  However, cope if it happens...")

              (replace EPAGE of STREAM with (ADD1 (fetch (M44STREAM LastPage)
                                                                 of STREAM)))
              (replace EOFFSET of STREAM with 0))
             (T (replace EPAGE of STREAM with (fetch (M44STREAM LastPage)
                                                             of STREAM))
                (replace EOFFSET of STREAM with (fetch (M44STREAM LastOffset)
                                                               of STREAM]
          (RETURN STREAM])

(\M44CREATEFILE
  [LAMBDA (FDEV UNAME LENGTH CRDATE TYPE DIRECTORYP)     (* ; "Edited 21-Jan-91 23:41 by jds")

    (* ;; "Create a file on the Model44 disk.")

    (PROG ((DSK (fetch (M44DEVICE DSKOBJ) of FDEV))
           (PNAME (\M44PACKFILENAME UNAME))
           (LEADERPAGE (create \M44LeaderPage))
           (NC 0)
           STREAM FP MAP FPBASE DAT PSTART)
          (OR PNAME (RETURN))                                (* ; 
                                                           "Cant create as name wasnt complete")
          (SETQ STREAM (create M44STREAM))
          (replace FULLFILENAME of STREAM with PNAME)
          (replace DEVICE of STREAM with FDEV)
          (replace (M44STREAM FID) of STREAM with (SETQ FP (create FID)))
          (replace (M44STREAM FILEPAGEMAP) of STREAM
             with (SETQ MAP (ARRAY (COND
                                          ((FIXP LENGTH)
                                           (IPLUS 4 (FOLDHI LENGTH BYTESPERPAGE)))
                                          (T PageMapIncrement))
                                       'WORD \FILLINDA 0)))
          (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with 0)
          (replace MULTIBUFFERHINT of STREAM with \M44MULTFLG)
          (replace (M44STREAM LEADERPAGE) of STREAM with LEADERPAGE)
          (SETQ FPBASE (fetch (ARRAYP BASE) of FP))
          (replace (FP FPSERIAL#) of FPBASE with (add (fetch (DSKOBJ 
                                                                                      DISKLASTSERIAL#
                                                                                        )
                                                                         of DSK)
                                                                    1))
          (COND
             (DIRECTORYP (add (fetch (FP FPSERIALHI) of FPBASE)
                                \FP.DIRECTORYP)))
          (replace (FP FPVERSION) of FPBASE with 1)
          (SETA MAP 0 \EOFDA)
          (SETA MAP 3 \EOFDA)                                (* ; 
                             "We are about to create pages 0 and 1, everything else is nonexistent")
                                                             (* ; 
                         "Done by the NCREATE -- (\ZEROPAGE (fetch (POINTER PAGE#) of LEADERPAGE))")
          (\BLT (LOCF (fetch (\M44LeaderPage TimeWrite) of LEADERPAGE))
                (SETQ DAT (\DAYTIME0 (create FIXP)))
                WORDSPERCELL)                                (* ; "Set creation and write dates")
          (\BLT (LOCF (fetch (\M44LeaderPage TimeCreate) of LEADERPAGE))
                (OR CRDATE DAT)
                WORDSPERCELL)                                (* ; 
                                                         "See \M44MAKEDIRENTRY for the name logic.")
          (for C in (fetch (UNAME ORIGCHARS) of UNAME)
             bind (NAMEBASE _ (LOCF (fetch (\M44LeaderPage NameCharCount) of LEADERPAGE))
                             )
                   (V _ (fetch (UNAME VERSION) of UNAME))
             do (\PUTBASEBYTE NAMEBASE (add NC 1)
                           C) finally [COND
                                             ((NEQ V 1)
                                              (\PUTBASEBYTE NAMEBASE (add NC 1)
                                                     (CHARCODE !))
                                              (for C in (CHCON V)
                                                 do (\PUTBASEBYTE NAMEBASE (add NC 1)
                                                               C]
                                    (\PUTBASEBYTE NAMEBASE (add NC 1)
                                           (CHARCODE %.))    (* ; 
                                                          "Last character of all alto names is dot")
                                    (replace (\M44LeaderPage NameCharCount) of LEADERPAGE
                                       with NC))
          (replace (\M44LeaderPage PropertyBegin) of LEADERPAGE
             with (INDEXF (FETCH (\M44LeaderPage LeaderProps) of LEADERPAGE)))
          [replace (\M44LeaderPage PropertyLength) of LEADERPAGE
             with (CONSTANT (- (INDEXF (FETCH (\M44LeaderPage Spares) of LEADERPAGE))
                                   (INDEXF (FETCH (\M44LeaderPage LeaderProps) of LEADERPAGE]
                                                             (* ; "The start and length of the property section are theoretically variable, but at least some %"official%" Alto software, such as Scavenge, believes that file names must be no more than 39 chars.")
          (\M44SETFILETYPE STREAM TYPE)
          (\WRITEDISKPAGES DSK (LIST LEADERPAGE NIL)
                 (fetch (ARRAYP BASE) of MAP)
                 -1 STREAM 0 1 NIL NIL 0 0)                  (* ; 
                    "The end of file will be zero and the validation not set as befits a new file.")
          (replace (FP FPLEADERVDA) of FPBASE with (\WORDELT MAP 1))
                                                             (* ; 
                                     "Now that the file is safely created, make entry in directory")
          (replace (M44STREAM DIRINFO) of STREAM with (\M44MAKEDIRENTRY
                                                                   (fetch (M44STREAM FID)
                                                                      of STREAM)
                                                                   UNAME NC FDEV))
          (RETURN STREAM])

(\M44DeleteFile
  [LAMBDA (FILENAME DEV)                                 (* ; "Edited 21-Jan-91 23:35 by jds")
                                                             (* ; "Delete a Model44 file.")
    (PROG ((STREAM (\M44GetFileHandle FILENAME 'OLDEST DEV T)))
          (COND
             ((OR (NOT STREAM)
                  (FDEVOP 'OPENP DEV (fetch FULLFILENAME of STREAM)
                         NIL DEV))                           (* ; "Can't delete an open file")
              (RETURN)))
          (\M44DELETEPAGES STREAM -1)
          (PROG ((DIROFD (fetch (M44DEVICE SYSDIROFD) of DEV)))
                                                             (* ; "Delete directory entry")
                (\SETFILEPTR DIROFD (fetch (M44STREAM DIRINFO) of STREAM))
                (\BOUT DIROFD (LOGAND 3 (\PEEKBIN DIROFD)))
                (FLUSHMAP DIROFD))
          (\M44KillFilePageMap STREAM)
          (replace (M44STREAM FID) of STREAM with NIL)
          (RETURN (fetch FULLFILENAME of STREAM])

(\M44EVENTFN
  [LAMBDA (FDEV EVENT)                                   (* ; "Edited 21-Jan-91 23:31 by jds")
    (DECLARE (GLOBALVARS \DEVICENAMETODEVICE \MACHINETYPE))
    (SELECTQ EVENT
        ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) 
                                                            (* ;; 
                                          "reinitialize DSK device and revalidate its open streams")

             [PROG ((DSKOBJ (fetch (M44DEVICE DSKOBJ) of FDEV))
                    DD)
                   (COND
                      ((SETQ DD (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSKOBJ))
                                                             (* ; 
                                                           "Flush out of date disk descriptor")
                       (FORGETPAGES DD)
                       (FDEVOP 'UNREGISTERFILE FDEV FDEV DD) (* ; 
      "Stream no longer in use.  Don't go thru \M44CloseFile because it will try to Truncate, etc.")
                       (replace (DSKOBJ DDVALID) of DSKOBJ with NIL)
                       (replace (DSKOBJ DISKDESCRIPTOROFD) of DSKOBJ with NIL)))
                   (FORGETPAGES (fetch (DSKOBJ SYSDIROFD) of DSKOBJ))
                   (FDEVOP 'UNREGISTERFILE FDEV FDEV (fetch (DSKOBJ SYSDIROFD) of DSKOBJ))
                   (COND
                      [(AND (EQ \MACHINETYPE \DORADO)
                            (LET [(PARTZEROP (EQ (fetch (M44DEVICE DSKPARTITION) of FDEV)
                                                 0))
                                  (CURPARTP (EQ (fetch (FDEV DEVICENAME) of FDEV)
                                                (PACK* 'DSK (DISKPARTITION]
                                 (COND
                                    (PARTZEROP               (* ; 
       "This is interlock with \M44EXTENDVMEMFILE which doesn't want to mess up the DiskDescriptor")
                                           (SETQ \M44.READY T)))
                                 (COND
                                    ((OR (AND PARTZEROP CURPARTP)
                                         (\DEVICE-OPEN-STREAMS FDEV))
                                     (COND
                                        ((EQ PARTZEROP CURPARTP)
                                                             (* ; 
                                              "No partition change to worry about, just reopen dir")
                                         (\OPENDIR FDEV))
                                        (PARTZEROP 

                                   (* ;; "This was the default partition, no longer is, so reopen it as if from scratch.  Also, remove the mapping of DSK to this device")

                                               (\REMOVEDEVICE.NAMES FDEV 'DSK)
                                               (\OPENDISK (SUBATOM (fetch (FDEV DEVICENAME)
                                                                          of FDEV)
                                                                     4)
                                                      FDEV))
                                        (T                   (* ; 
       "This was a non-default partition, now the default.  Reopen it with \MAINDISK as its DSKOBJ")
                                           (\OPENDISKDEVICE NIL NIL FDEV]
                      (T 
                         (* ;; "Device no longer exists if machine is now Dandelion;  and if there were no open files, no need to try reopening the dir")

                         (replace (DSKOBJ SYSDIROFD) of DSKOBJ with NIL)

                         (* ;; "Have to explicitly clear these fields, because when we drop the DSKOBJ on the floor, GC does not know about its POINTER fields")

                         (replace REOPENFILE of FDEV with (FUNCTION NILL))
                                                             (* ; 
                            "In case there are files open over sysout as we come back on Dandelion")
                         (\REMOVEDEVICE FDEV]
             (\PAGED.REVALIDATEFILELST FDEV))
        (BEFORELOGOUT (\FLUSH.OPEN.STREAMS FDEV)
                      (\M44FLUSHDISKDESCRIPTOR FDEV))
        NIL])

(\M44ExtendFilePageMap
  [LAMBDA (STREAM TOPAGE#)                               (* ; "Edited 21-Jan-91 23:35 by jds")

    (* ;; "If the file's page map is not big enough to map the given page, then create a new one that is big enough and copy the old OLDMAP information into the new map.  If the file has no map, then create one big enough to map the given page.  Return the new map.  --- Map entry 0 corresponds to bfs page -1, entry 1 corresponds to the leader page, and entry 2 corresponds to Lisp page 0")

    (PROG ((OLDMAP (fetch (M44STREAM FILEPAGEMAP) of STREAM))
           OLDSIZE NEWMAP)
          (RETURN (COND
                     ([AND OLDMAP (ILESSP (IPLUS TOPAGE# 3)
                                         (SETQ OLDSIZE (fetch (ARRAYP LENGTH) of OLDMAP]
                      OLDMAP)
                     (T (SETQ NEWMAP (ARRAY (CEIL (IPLUS TOPAGE# 4)
                                                  PageMapIncrement)
                                            'SMALLPOSP \FILLINDA 0))
                        [COND
                           (OLDMAP                           (* ; "Copy old map into new")
                                  (\BLT (fetch (ARRAYP BASE) of NEWMAP)
                                        (fetch (ARRAYP BASE) of OLDMAP)
                                        OLDSIZE))
                           (T                                (* ; 
                                                           "Initialize with leader page hint")
                              (SETA NEWMAP 0 \EOFDA)
                              (SETA NEWMAP 1 (fetch (FP FPLEADERVDA)
                                                of (fetch (ARRAYP BASE)
                                                          of (fetch (M44STREAM FID)
                                                                    of STREAM]
                        (replace (M44STREAM FILEPAGEMAP) of STREAM with NEWMAP)
                        NEWMAP])

(\M44FillInMap
  [LAMBDA (STREAM UPTOPAGE)                              (* ; "Edited 21-Jan-91 23:42 by jds")

(* ;;; "Assures that the disk address map for STREAM is filled in up thru page# UPTOPAGE.  Reads file as needed")

    (PROG ((MAP (\M44ExtendFilePageMap STREAM UPTOPAGE))
           (DSK (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)))
           (LASTKNOWNPAGE (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
           NPAGES LASTPAGEREAD LASTATTEMPTED DAs DA)         (* ; "Extend MAP")
          (SETQ DAs (fetch (ARRAYP BASE) of MAP))
          [while (ILESSP LASTKNOWNPAGE UPTOPAGE)
             do (COND
                       [(NEQ (SETQ DA (\GETBASE DAs (IPLUS LASTKNOWNPAGE 1 2)))
                             \FILLINDA)                      (* ; 
                               "There already is an entry for the next page, so no need to read it")
                        (COND
                           ((EQ DA \EOFDA)
                            (RETURN))
                           (T (add LASTKNOWNPAGE 1]
                       (T [SETQ NPAGES (IMIN \MAXDISKDAs (ADD1 (IDIFFERENCE UPTOPAGE LASTKNOWNPAGE]

                          (* ;; "We know where LASTKNOWNPAGE lives, so read it to find out where the next page after that is.  Can do this for many pages at once to make it reasonable")

                          (SETQ LASTPAGEREAD (\ACTONDISKPAGES DSK NIL DAs -1 STREAM (.LISP.TO.BFS.
                                                                                     LASTKNOWNPAGE)
                                                    [SETQ LASTATTEMPTED
                                                     (.LISP.TO.BFS. (SUB1 (IPLUS LASTKNOWNPAGE NPAGES
                                                                                 ]
                                                    \DC.READD))
                          (SETQ LASTKNOWNPAGE (.BFS.TO.LISP. LASTPAGEREAD))
                          (COND
                             ((ILESSP LASTPAGEREAD LASTATTEMPTED)
                                                             (* ; "Hit end of file")
                              (RETURN]
          (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with LASTKNOWNPAGE)
          (RETURN LASTKNOWNPAGE])

(\M44GetFileHandle
  [LAMBDA (NAME RECOG FDEV FAST CREATEFLG)               (* ; "Edited 21-Jan-91 23:48 by jds")

    (* ;; "Creates a STREAM for dsk file NAME.  If file does not exist, but CREATEFLG is true, returns the UNAME of the file so that it may be created.  If FAST is true, does not fill in any fields of STREAM that would require reading the file, e.g., the length and full map")

    (LET ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of FDEV))
          FS DP STREAM)
         (COND
            ((NULL DIRSTREAM)                                (* ; "Non-existent device")
             NIL)
            ((NULL (SETQ FS (\M44PARSEFILENAME NAME RECOG FDEV CREATEFLG)))
                                                             (* ; "File not found")
             NIL)
            ((SETQ DP (fetch (FILESPEC FSDIRPTR) of FS))
                                                             (* ; 
                                                     "File was found--here's the directory pointer")
             (SETQ STREAM (create M44STREAM))
             (replace DEVICE of STREAM with FDEV)
             (replace (M44STREAM FID) of STREAM with (\M44READDIRFID DIRSTREAM DP))
             (replace (M44STREAM DIRINFO) of STREAM with DP)
             (replace FULLFILENAME of STREAM with (\M44PACKFILENAME
                                                               (fetch (FILESPEC UNAME)
                                                                  of FS)
                                                               DP DIRSTREAM))
             (replace MULTIBUFFERHINT of STREAM with \M44MULTFLG)
             (OR FAST (\M44CompleteFH STREAM))
             STREAM)
            ((NULL (fetch (FILESPEC UNAME) of FS))   (* ; 
                                           "Name was malformed--can't create it even if we want to")
             (LISPERROR "BAD FILE NAME" NAME))
            (CREATEFLG (fetch (FILESPEC UNAME) of FS])

(\M44GetFileInfo
  [LAMBDA (STREAM ATTRIBUTE DEV)                         (* ; "Edited 21-Jan-91 23:44 by jds")

    (* ;; "Get the value of the ATTRIBUTE for a model44 file.  If STREAM is a filename, then the file is not open.")

    (COND
       ((OR (type? STREAM STREAM)
            (SETQ STREAM (\M44GetFileHandle STREAM 'OLD DEV T)))
        (SELECTQ ATTRIBUTE
            ((LENGTH SIZE) 
                 (COND
                    ((NULL (fetch VALIDATION of STREAM))
                                                             (* ; 
                                                       "Need to read leader page etc to get length")
                     (\M44CompleteFH STREAM)))
                 (SELECTQ ATTRIBUTE
                     (LENGTH (create BYTEPTR
                                    PAGE _ (fetch EPAGE of STREAM)
                                    OFFSET _ (fetch EOFFSET of STREAM)))
                     (IPLUS (fetch EPAGE of STREAM)
                            (FOLDHI (fetch EOFFSET of STREAM)
                                   BYTESPERPAGE))))
            (TYPE [PROG ((BUF (\M44ReadLeaderPage STREAM)))
                        (RETURN
                         (COND
                            ((IGREATERP (fetch (\M44LeaderPage PropertyLength) of BUF)
                                    0)
                             (SETQ BUF (\ADDBASE BUF (fetch (\M44LeaderPage PropertyBegin)
                                                        of BUF)))
                             (do (SELECTC (fetch (M44FILEPROP FPROPTYPE) of BUF)
                                         (0                  (* ; "End of properties")
                                            (RETURN))
                                         (\FPROP.TYPE [RETURN (SELECTC (fetch (M44FILEPROP 
                                                                                         FPROPWORD0)
                                                                          of BUF)
                                                                  (\FPTYPE.TEXT 'TEXT)
                                                                  (\FPTYPE.BINARY 
                                                                       'BINARY)
                                                                  (\FPTYPE.UNKNOWN 
                                                                       NIL)
                                                                  (\TYPE.FROM.FILETYPE
                                                                   (fetch (M44FILEPROP FPROPWORD0
                                                                                     ) of BUF])
                                         NIL)
                                    (SETQ BUF (\ADDBASE BUF (fetch (M44FILEPROP FPROPLENGTH)
                                                               of BUF])
            (CREATIONDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeCreate)
                                                                 of T))
                                 T))
            (WRITEDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeWrite)
                                                              of T))
                              T))
            (READDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeRead)
                                                             of T))
                             T))
            (ICREATIONDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeCreate)
                                                                  of T))))
            (IWRITEDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeWrite)
                                                               of T))))
            (IREADDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeRead)
                                                              of T))))
            NIL])

(\M44GETDATEPROP
(LAMBDA (STREAM OFFSET STRINGIFY) (* bvm%: "27-May-84 22:57") (* ;; "Returns the create/write/read date of STREAM that lives at OFFSET in its leader page, as a string if STRINGIFY is true, else as a Lisp date fixp") (PROG ((DATEBASE (\ADDBASE (\M44ReadLeaderPage STREAM) OFFSET)) DAT) (SETQ DAT (\MAKENUMBER (\GETBASE DATEBASE 0) (\GETBASE DATEBASE 1))) (RETURN (COND ((NEQ DAT 0) (SETQ DAT (ALTO.TO.LISP.DATE DAT)) (COND (STRINGIFY (GDATE DAT)) (T DAT)))))))
)

(\M44GetFileName
  [LAMBDA (NAME RECOG FDEV)                              (* ; "Edited 21-Jan-91 23:48 by jds")
    (LET ((FS (\M44PARSEFILENAME NAME RECOG FDEV))
          DP UNAME)
         (AND FS (SETQ UNAME (fetch (FILESPEC UNAME) of FS))
              (\M44PACKFILENAME UNAME (SETQ DP (fetch (FILESPEC FSDIRPTR) of FS))
                     (AND DP (fetch (M44DEVICE SYSDIROFD) of FDEV])

(\M44GetPageLoc
  [LAMBDA (STREAM PAGENO CREATE?)                        (* ; "Edited 21-Jan-91 23:35 by jds")

    (* ;; "Look in the file's page map to find the disk address of the page.  If the map does not include the page, then extend it appropriately.  If page does not exit, create it if CREATE?  is true, else return \EOFDA")

    (COND
       ((ILEQ PAGENO (fetch (M44STREAM LastPage) of STREAM))
        (COND
           ((IGREATERP PAGENO (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
            (\M44FillInMap STREAM PAGENO)))
        (\WORDELT (fetch (M44STREAM FILEPAGEMAP) of STREAM)
               (IPLUS PAGENO 2)))
       (CREATE? (\M44AddDiskPages STREAM PAGENO 0)
              (\M44GetPageLoc STREAM PAGENO))
       (T \EOFDA])

(\M44KillFilePageMap
  [LAMBDA (fHandle)                                      (* ; "Edited 21-Jan-91 23:35 by jds")
                                                             (* ; "Remove the file's page map.")
    (replace (M44STREAM FILEPAGEMAP) of fHandle with NIL)
    (replace (M44STREAM LASTMAPPEDPAGE) of fHandle with -1])

(\M44MAKEDIRENTRY
  [LAMBDA (FID UNAME NC FDEV)                            (* ; "Edited 21-Jan-91 23:38 by jds")

    (* ;; "Makes a directory entry for a new file.  FID is file's ID, NC the number of characters in the full Alto name.")

    (PROG ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of FDEV))
           (VERSION (fetch (UNAME VERSION) of UNAME))
           POS)
          (SETQ POS (\FINDDIRHOLE (LRSH (IPLUS NC 14)
                                            1)
                           DIRSTREAM))
          (\BOUTS DIRSTREAM (fetch (FID FIDBLOCK) of FID)
                 0
                 (UNFOLD 5 BYTESPERWORD))
          (\BOUT DIRSTREAM NC)

     (* ;; "Now write out the alto-style name 'name[.ext]!ver.' with ver omitted if 1;  This is basically the same logic as is used to write the name in the leader page in \M44CREATEFILE.  We can't share cause here we do bouts, cause we might run over a page;  there we must do PUTBASEBYTE's cause we can't set the fileptr to the leader page.")

          (for C in (fetch (UNAME ORIGCHARS) of UNAME) do (\BOUT DIRSTREAM C))
          [COND
             ((NEQ VERSION 1)
              (\BOUT DIRSTREAM (CHARCODE !))
              (LET ((*PRINT-BASE* 10))
                   (PRIN3 VERSION DIRSTREAM]
          (\BOUT DIRSTREAM (CHARCODE %.))
          (COND
             ((EVENP NC BYTESPERWORD)
              (\BOUT DIRSTREAM 0)))
          (\SETFILEPTR DIRSTREAM POS)
          (\BOUT DIRSTREAM (LOGOR 4 (\PEEKBIN DIRSTREAM)))   (* ; 
                             "When everything is ready, finally change the type from hole to file.")
          (FORCEOUTPUT DIRSTREAM)
          (RETURN POS])

(\M44OpenFile
  [LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM)  (* ; "Edited 21-Jan-91 23:38 by jds")

    (* ;; "Open a Model44 file.  Gets the physical end of file and sets up ofd")

    (PROG (PAGESTIMATE STREAM CRDATE TYPE DON'T.CHANGE.DATE X)
                                                             (* ; 
                                                       "if file is open in a conflicting way, barf")
          [COND
             ((NEQ ACCESS 'INPUT)                            (* ; 
                                                      "Interesting parameters when creating a file")
              (for X in PARAMETERS do (SELECTQ (CAR (LISTP X))
                                                      (LENGTH (SETQ PAGESTIMATE
                                                               (IPLUS 2 (FOLDHI (CADR X)
                                                                               BYTESPERPAGE))))
                                                      (CREATIONDATE (SETQ CRDATE (IDATE (CADR X))))
                                                      (ICREATIONDATE (SETQ CRDATE (CADR X)))
                                                      (TYPE (SETQ TYPE (CADR X)))
                                                      (DON'T.CHANGE.DATE 
                                                           (SETQ DON'T.CHANGE.DATE T))
                                                      NIL]
          (COND
             [(type? STREAM NAME)
              (COND
                 ((OR (fetch (M44DEVICE DSKPASSWORDOK) of (fetch DEVICE of NAME))
                      (EQ (fetch (FID W0) of (fetch (M44STREAM FID) of NAME))
                          32768))                            (* ; 
                            "Make sure password is ok if trying to reopen anything but a directory")
                  (\M44CompleteFH (SETQ STREAM NAME)))
                 (T (RETURN]
             ([NULL (SETQ STREAM (\M44GetFileHandle NAME RECOG FDEV NIL (NEQ ACCESS 'INPUT]
                                                             (* ; 
                  "File not found.  Return NIL to let generic open generate a FILE NOT FOUND error")
              (RETURN NIL)))
          (if OLDSTREAM
              then                                       (* ; "REOPENFILE--nothing more to do")
                    (RETURN STREAM))
          [COND
             ([AND PAGESTIMATE (IGREATERP PAGESTIMATE (IPLUS (fetch (M44DEVICE DISKFREEPAGES)
                                                                of FDEV)
                                                             (COND
                                                                ((type? STREAM STREAM)
                                                                 (fetch (M44STREAM LastPage)
                                                                    of STREAM))
                                                                (T 
                                                             (* ; "New file")
                                                                   0]
              (RETURN (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" (COND
                                                                     ((type? STREAM STREAM)
                                                                      (fetch FULLFILENAME
                                                                         of STREAM))
                                                                     (T NAME]
          [COND
             (CRDATE                                         (* ; "Convert to alto format")
                    (COND
                       ([NOT (type? FIXP (SETQ CRDATE (LISP.TO.ALTO.DATE CRDATE]
                                                             (* ; "sigh, wanted a number box")
                        (\PUTBASEFIXP (SETQ X (create FIXP))
                               0 CRDATE)
                        (SETQ CRDATE X]
          [COND
             ((NOT (type? STREAM STREAM))                (* ; "New file")
              (SETQ STREAM (\M44CREATEFILE FDEV STREAM PAGESTIMATE CRDATE TYPE)))
             (T                                              (* ; "Old file")
                [LET ((MYNAME (fetch FULLFILENAME of STREAM)))
                     (COND
                        ([for OTHER in (fetch (FDEV OPENFILELST) of FDEV)
                            when (STRING-EQUAL (fetch FULLFILENAME of OTHER)
                                            MYNAME)
                            do (RETURN (OR (NEQ ACCESS 'INPUT)
                                               (NEQ (fetch ACCESS of OTHER)
                                                    'INPUT]  (* ; 
                                                          "Access conflict with existing open file")
                         (RETURN (LISPERROR "FILE WON'T OPEN" MYNAME]
                [COND
                   ((EQ ACCESS 'OUTPUT)                      (* ; "File is EMPTY even if it is old")
                    (replace EPAGE of STREAM with (replace EOFFSET of STREAM
                                                                 with 0]
                                                             (* ; 
                                              "Leader page is read in during STREAM initialization")
                (COND
                   ((NOT DON'T.CHANGE.DATE)
                    (\M44SetAccessTimes STREAM ACCESS CRDATE)
                                                             (* ; "Resets validation")
                    (\M44WriteLeaderPage STREAM)         (* ; 
                                                  "We write out accumulated changes to leader page")
                    ]
          (COND
             (CRDATE (replace NONDEFAULTDATEFLG of STREAM with T)))
          (RETURN STREAM])

(\M44OPENFILEFROMFP
  [LAMBDA (DEV NAME ACCESS FID DIRINFO)                  (* ; "Edited 21-Jan-91 23:36 by jds")
                                                             (* ; "Opens a disk file given its FP")
    (LET ((STREAM (create M44STREAM)))
         (replace FULLFILENAME of STREAM with (SETQ NAME (PACK* '{ (fetch
                                                                                (FDEV DEVICENAME)
                                                                                  of DEV)
                                                                            '} NAME)))
         (replace DEVICE of STREAM with DEV)
         (replace (M44STREAM FID) of STREAM with FID)
         (replace (M44STREAM DIRINFO) of STREAM with DIRINFO)
         (replace MULTIBUFFERHINT of STREAM with \M44MULTFLG)
         (\OPENFILE STREAM ACCESS)
         (replace USERVISIBLE of STREAM with NIL)
         STREAM])

(\M44ReadDiskPage
  [LAMBDA (STREAM PAGENO BUF)                            (* ; "Edited 21-Jan-91 23:42 by jds")

    (* ;; "The functions for reading a disk page called by \M44ReadPages.  Returns the number of bytes read.  If PAGEADDR is 0, then assume 0 bytes read.  Fill the BUF with zeros beyond the last byte read.")

    (COND
       ((AND (IGEQ PAGENO (fetch EPAGE of STREAM))
             (OR (NOT (IEQP PAGENO (fetch EPAGE of STREAM)))
                 (EQ (fetch EOFFSET of STREAM)
                     0)))                                    (* ; 
                        "Asking for page after eof.  PMAP system really ought to catch this itself")
        (\CLEARWORDS BUF WORDSPERPAGE)
        0)
       (T (PROG ((PAGEADDR (\M44GetPageLoc STREAM PAGENO))
                 (BFSPG# (ADD1 PAGENO)))
                (RETURN (COND
                           ((EQ PAGEADDR \EOFDA)             (* ; 
                                                           "no bytes read, fill with zeroes.")
                            (\CLEARWORDS BUF WORDSPERPAGE)
                            0)
                           ((EQ PAGEADDR \FILLINDA)
                            (SHOULDNT))
                           ((EQ (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ)
                                                    of (fetch DEVICE of STREAM))
                                       BUF
                                       (fetch (ARRAYP BASE) of (fetch (M44STREAM 
                                                                                         FILEPAGEMAP)
                                                                          of STREAM))
                                       -1 STREAM BFSPG# BFSPG# \DC.READD)
                                BFSPG#)
                            BYTESPERPAGE)
                           (T 
                              (* ;; "if READDISKPAGE returns NIL, presumably there is an error of some kind, hope it was with the file map and try again.")

                              (\M44KillFilePageMap STREAM)
                              (\M44ReadDiskPage STREAM PAGENO BUF])

(\M44ReadLeaderPage
  [LAMBDA (STREAM AGAIN)                                 (* ; "Edited 21-Jan-91 23:42 by jds")

(* ;;; "Returns the leader page of STREAM, reading it if necessary.  If AGAIN is true, will read it afresh even if it already has a cached leader page")

    (* ;; "File leader page format: Words 0-1, time created.  Words 2-3, time last written.  Words 4-5, time last read.  Words 6-25, name of file.  Words 26-235, leader properties.  Words 236-245, spare.  Word 246, property pointer.  Word 247, change serial number.  Words 248-252, STREAM hint for directory.  Word 253, disk address of last page.  Word 254, page number of last page.  Word 255, number of bytes on last page.")

    (PROG ((BUFFER (fetch (M44STREAM LEADERPAGE) of STREAM)))
          (COND
             [(NULL BUFFER)
              (SETQ BUFFER (NCREATE 'VMEMPAGEP]
             ((NOT AGAIN)
              (RETURN BUFFER)))
          (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM))
                 BUFFER
                 (fetch (ARRAYP BASE) of (OR (fetch (M44STREAM FILEPAGEMAP) of STREAM
                                                            )
                                                     (\MAKELEADERDAS STREAM)))
                 -1 STREAM 0 0 \DC.READD)
          (replace (M44STREAM LEADERPAGE) of STREAM with BUFFER)
          (RETURN BUFFER])

(\M44ReadPages
(LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* bvm%: "26-DEC-81 23:50") (* ; "Read pages from a Model44 file.") (for BUF inside BUFFERS as PAGENO from FIRSTPAGE# sum (\M44ReadDiskPage STREAM PAGENO BUF)))
)

(\M44SetAccessTimes
  [LAMBDA (STREAM ACCESS CRDATE)                         (* ; "Edited 21-Jan-91 23:36 by jds")

(* ;;; "Set the 'last read' and/or 'last written' times in the leader page according to access, which is assumed to be either INPUT, OUTPUT, BOTH, or APPEND.")

    (PROG ((DAT (\DAYTIME0 (create FIXP)))
           (BUF (fetch (M44STREAM LEADERPAGE) of STREAM)))

     (* ;; "Note: DAYTIME0 returns an Alto time, not Lisp time.  This is consistent with the dates in the leader page")

          (SELECTQ ACCESS
              ((OUTPUT BOTH APPEND) 
                   (\BLT (LOCF (fetch (\M44LeaderPage TimeCreate) of BUF))
                         (OR CRDATE DAT)
                         WORDSPERCELL)
                   (\BLT (LOCF (fetch (\M44LeaderPage TimeWrite) of BUF))
                         DAT WORDSPERCELL)                   (* ; 
                                                    "Must revalidate because write DAT has changed")
                   (UPDATEVALIDATION STREAM BUF))
              NIL)
          (SELECTQ ACCESS
              ((INPUT BOTH) 
                   (\BLT (LOCF (fetch (\M44LeaderPage TimeRead) of BUF))
                         DAT WORDSPERCELL))
              NIL])

(\M44SetEndOfFile
  [LAMBDA (STREAM EPAGE EOFFSET UPDATENOW)               (* ; "Edited 21-Jan-91 23:36 by jds")

    (* ;; "Reset the file's leader page end-of-file hint.  If UPDATENOW is NIL, then simply update the leader page.  If it is not, then read and write the leader page.")

    (UNINTERRUPTABLY
        
        (* ;; "Must update STREAM handle and leader page in synch")

        (replace (M44STREAM LastPage) of STREAM with EPAGE)
        (replace (M44STREAM LastOffset) of STREAM with EOFFSET)
        [LET ((LEADERPAGE (\M44ReadLeaderPage STREAM)))
             (if (NEQ (fetch (\M44LeaderPage LastPageNumber) of LEADERPAGE)
                          (ADD1 EPAGE))
                 then                                    (* ; 
                                                    "if LastPage hasn't changed, don't do anything")
                                                             (* ; "ADD1 because M44 counts from 1")
                       (replace (\M44LeaderPage LastPageAddress) of LEADERPAGE
                          with (\M44GetPageLoc STREAM EPAGE))
                       (replace (\M44LeaderPage LastPageNumber) of LEADERPAGE
                          with (ADD1 EPAGE)))
             (replace (\M44LeaderPage LastPageByteCount) of LEADERPAGE with EOFFSET)
             (COND
                (UPDATENOW (\M44WriteLeaderPage STREAM])])

(\M44SetFileInfo
  [LAMBDA (STREAM ATTRIBUTE VALUE DEV)                   (* ; "Edited 21-Jan-91 23:34 by jds")
    (PROG ((WASOPEN (type? STREAM STREAM)))
          (SELECTQ ATTRIBUTE
              (CREATIONDATE (SETQ VALUE (OR (IDATE VALUE)
                                            (LISPERROR "ILLEGAL ARG" VALUE))))
              (ICREATIONDATE (OR (FIXP VALUE)
                                 (LISPERROR "NON-NUMERIC ARG" VALUE)))
              (TYPE)
              (RETURN))
          (RETURN (COND
                     ((OR WASOPEN (SETQ STREAM (\M44GetFileHandle STREAM 'OLD DEV T)))
                      (COND
                         ((SELECTQ ATTRIBUTE
                              (TYPE (\M44SETFILETYPE STREAM VALUE))
                              (PROGN (replace (\M44LeaderPage TimeCreate) of (
                                                                                 \M44ReadLeaderPage
                                                                                      STREAM)
                                        with (LISP.TO.ALTO.DATE VALUE))
                                     T))
                          (\M44WriteLeaderPage STREAM)
                          T])

(\M44SETFILETYPE
  [LAMBDA (STREAM TYPE)                                  (* ; "Edited 21-Jan-91 23:44 by jds")

    (* ;; "Set TYPE attribute of file to be TYPE -- assumes someone else will be writing out the leader page later")

    (PROG ((TYPECODE (SELECTQ TYPE
                         (TEXT \FPTYPE.TEXT)
                         (BINARY \FPTYPE.BINARY)
                         (NIL \FPTYPE.UNKNOWN)
                         (OR (\FILETYPE.FROM.TYPE TYPE)
                             \FPTYPE.BINARY)))
           (BUF (\M44ReadLeaderPage STREAM))
           PTR TOTALLENGTH)

     (* ;; "Computation of TYPECODE done this way for backward compatibility -- the \FPTYPE.xx constants were defined before \FILETYPE.FROM.TYPE was written, and the numbers are incompatible")

          (SETQ PTR (\ADDBASE BUF (fetch (\M44LeaderPage PropertyBegin) of BUF)))
          (SETQ TOTALLENGTH (fetch (\M44LeaderPage PropertyLength) of BUF))
          (RETURN (while (IGREATERP TOTALLENGTH 0)
                     do (SELECTC (fetch (M44FILEPROP FPROPTYPE) of PTR)
                                (0                           (* ; "End of properties")
                                   (RETURN (COND
                                              ((IGREATERP TOTALLENGTH 1)
                                               (replace (M44FILEPROP FPROPWORD0) of PTR
                                                  with TYPECODE)
                                               (replace (M44FILEPROP FPROPLENGTH) of PTR
                                                  with 2)
                                               (replace (M44FILEPROP FPROPTYPE) of PTR
                                                  with \FPROP.TYPE)
                                               T))))
                                (\FPROP.TYPE                 (* ; "Already has a type, change it")
                                             (replace (M44FILEPROP FPROPWORD0) of PTR
                                                with TYPECODE)
                                             (RETURN T))
                                NIL)
                           (SETQ PTR (\ADDBASE PTR (fetch (M44FILEPROP FPROPLENGTH) of PTR)))
                           (SETQ TOTALLENGTH (IDIFFERENCE TOTALLENGTH (fetch (M44FILEPROP 
                                                                                        FPROPLENGTH)
                                                                         of PTR])

(\M44TruncateFile
  [LAMBDA (STREAM LP LO UPDATENOW)                       (* ; "Edited 21-Jan-91 23:36 by jds")

    (* ;; 
  "Resets the length of the file to LP page and LO offset.  Can both shorten and lengthen files.")

    [COND
       ((NOT LP)
        (SETQ LP (fetch EPAGE of STREAM))
        (SETQ LO (fetch EOFFSET of STREAM]
    (COND
       ((IGREATERP LP (fetch (M44STREAM LastPage) of STREAM))
        (\M44AddDiskPages STREAM LP LO))
       ((ILESSP LP (fetch (M44STREAM LastPage) of STREAM))
        (\M44DELETEPAGES STREAM (ADD1 LP))
        (COND
           ((ILESSP LP (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
            (for I from (ADD1 LP) to (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)
               do (SETA (fetch (M44STREAM FILEPAGEMAP) of STREAM)
                            (IPLUS I 2)
                            \EOFDA))
            (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with LP)))
        (\M44SetEndOfFile STREAM LP LO)                  (* ; 
                                 "Now need to rewrite last page with new length, null next pointer")
        (\MAPPAGE LP STREAM)
        (\SETIODIRTY STREAM LP)
        (FORCEOUTPUT STREAM))
       (T (replace (M44STREAM LastOffset) of STREAM with LO)))
    (AND UPDATENOW (\M44SetEndOfFile STREAM LP LO T))
    STREAM])

(\M44WriteDiskPage
  [LAMBDA (STREAM PAGENO BUF NBYTES)                     (* ; "Edited 21-Jan-91 23:42 by jds")
                                                             (* ; 
                                                           "Write a disk page on the Model44.")
    (\M44GetPageLoc STREAM PAGENO T)                     (* ; "Ensure that PAGENO is in map")
    (PROG ((BFSPG# (ADD1 PAGENO)))
          (RETURN (COND
                     ([COND
                         ((NEQ PAGENO (fetch (M44STREAM LastPage) of STREAM))
                                                             (* ; "Writing only data")
                          (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE
                                                                                   of STREAM))
                                 BUF
                                 (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP)
                                                                    of STREAM))
                                 -1 STREAM BFSPG# BFSPG# \DC.WRITED))
                         (T                                  (* ; 
           "When writing last page, need to fill in the numchars field of label, so this is harder")
                            (COND
                               ((EQ PAGENO (fetch EPAGE of STREAM))
                                (EQ (\WRITEDISKPAGES (fetch (M44DEVICE DSKOBJ)
                                                        of (fetch DEVICE of STREAM))
                                           BUF
                                           (fetch (ARRAYP BASE) of (fetch (M44STREAM
                                                                                       FILEPAGEMAP)
                                                                              of STREAM))
                                           -1 STREAM BFSPG# BFSPG# NIL NIL NBYTES)
                                    BFSPG#))
                               (T 

                                 (* ;; "We will have to write more pages after this one, too, unless the file is truncated back to here, so extend the file while we're at it.  This may save a call to \ADDDISKPAGES")

                                  [COND
                                     ((ILEQ (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)
                                            PAGENO)
                                      (\M44ExtendFilePageMap STREAM (ADD1 PAGENO]
                                  (COND
                                     ((EQ (\WRITEDISKPAGES (fetch (M44DEVICE DSKOBJ)
                                                              of (fetch DEVICE of STREAM)
                                                                  )
                                                 (LIST BUF NIL)
                                                 (fetch (ARRAYP BASE) of (fetch
                                                                                  (M44STREAM 
                                                                                         FILEPAGEMAP)
                                                                                    of STREAM))
                                                 -1 STREAM BFSPG# (ADD1 BFSPG#)
                                                 NIL NIL 0)
                                          (ADD1 BFSPG#))     (* ; 
                                                    "Write two pages, the second of which is blank")
                                      (replace (M44STREAM LastPage) of STREAM
                                         with (ADD1 PAGENO))
                                      (replace (M44STREAM LastOffset) of STREAM with
                                                                                        0)
                                      T]
                      NBYTES)
                     (T (\M44KillFilePageMap STREAM)
                        (\M44WriteDiskPage STREAM PAGENO BUF NBYTES])

(\M44WriteLeaderPage
  [LAMBDA (STREAM)                                       (* ; "Edited 21-Jan-91 23:42 by jds")
                                                             (* ; "Write the file's leader page")
    (PROG ((BUFFER (fetch (M44STREAM LEADERPAGE) of STREAM)))
          (AND BUFFER (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE
                                                                               of STREAM))
                             BUFFER
                             (fetch (ARRAYP BASE) of (OR (fetch (M44STREAM FILEPAGEMAP)
                                                                    of STREAM)
                                                                 (\MAKELEADERDAS STREAM)))
                             -1 STREAM 0 0 \DC.WRITED])

(\M44WritePages
  [LAMBDA (STREAM FIRSTPAGE# BUFFERS)                    (* ; "Edited 21-Jan-91 23:36 by jds")
                                                             (* ; 
                                                           "Write pages onto a Model44 file.")
    (PROG ([NPAGES (COND
                      ((NLISTP BUFFERS)
                       1)
                      (T (for B in BUFFERS sum 1]
           LASTPAGE#)
          (COND
             ((fetch REVALIDATEFLG of STREAM)

              (* ;; "Need to update creationdate, since a SAVEVM etc has occurred since the last write.  Otherwise, it is possible to see a change to the file but no change to the creationdate")

              (\M44SetAccessTimes STREAM 'OUTPUT)
              (\M44WriteLeaderPage STREAM)
              (replace REVALIDATEFLG of STREAM with NIL)))
          (\M44GetPageLoc STREAM FIRSTPAGE# T)           (* ; 
                                                 "Make sure we know where we are starting to write")
          [COND
             ([ILESSP (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)
                     (SETQ LASTPAGE# (IPLUS FIRSTPAGE# (SUB1 NPAGES]
                                                             (* ; 
                                                 "Need enough pagemap to cover everything we write")
              (\M44ExtendFilePageMap STREAM (ADD1 LASTPAGE#]
          [COND
             ([AND (IGEQ NPAGES \#DISKBUFFERS)
                   (for B in BUFFERS thereis (NOT (EMADDRESSP B]

              (* ;; "More pages to write than we have disk buffers to do it in one command, so break it up.  Buffers already in emulator space are free, though, so we can write lots of them")

              (bind (MAXPAGES _ (SUB1 \#DISKBUFFERS))
                 do (\M44WritePages1 STREAM FIRSTPAGE# (IPLUS FIRSTPAGE# (SUB1 MAXPAGES))
                               (to MAXPAGES collect (pop BUFFERS)))
                       (add FIRSTPAGE# MAXPAGES)
                       (SETQ NPAGES (IDIFFERENCE NPAGES MAXPAGES)) repeatwhile (IGREATERP NPAGES
                                                                                          MAXPAGES]
          (\M44WritePages1 STREAM FIRSTPAGE# LASTPAGE# BUFFERS])

(\M44WritePages1
  [LAMBDA (STREAM FIRSTPAGE# LASTPAGE# BUFFERS)          (* ; "Edited 21-Jan-91 23:42 by jds")

(* ;;; "Writes BUFFERS to STREAM, covering pages FIRSTPAGE# thru LASTPAGE#.  Caller guarantees that we have enough disk buffers to do it.  --- There are two cases: easy one is if the pages already exist, in which case we just rewrite their data;  hard case is writing pages at end of file, in which case we need to write labels and maybe allocate pages")

    (COND
       ((ILESSP LASTPAGE# (fetch (M44STREAM LastPage) of STREAM))
                                                             (* ; "Writing only data")
        (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM))
               BUFFERS
               (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP) of STREAM))
               -1 STREAM (.LISP.TO.BFS. FIRSTPAGE#)
               (.LISP.TO.BFS. LASTPAGE#)
               \DC.WRITED))
       (T                                                    (* ; 
           "When writing last page, need to fill in the numchars field of label, so this is harder")
          (PROG (MYBUFS NBYTES)
                [SETQ MYBUFS (COND
                                ((AND (EQ LASTPAGE# (fetch EPAGE of STREAM))
                                      (NEQ (SETQ NBYTES (fetch EOFFSET of STREAM))
                                           BYTESPERPAGE))    (* ; 
                                                           "Only write to the end of the file")
                                 BUFFERS)
                                (T 

                                 (* ;; "We will have to write more pages after this one, too, unless the file is truncated back to here, so extend the file while we're at it.  This may save a call to \ADDDISKPAGES")

                                   (PROG1 (SETQ MYBUFS (CONS))
                                       [for B inside BUFFERS
                                          do (RPLACA MYBUFS B)
                                                (SETQ MYBUFS (CDR (RPLACD MYBUFS (CONS]
                                       (RPLACD (RPLACA MYBUFS NIL)
                                              NIL)           (* ; "Write a final blank page")
                                       (SETQ NBYTES 0)
                                       (add LASTPAGE# 1))]
                (\WRITEDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM
                                                                             ))
                       MYBUFS
                       (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP)
                                                          of STREAM))
                       -1 STREAM (.LISP.TO.BFS. FIRSTPAGE#)
                       (.LISP.TO.BFS. LASTPAGE#)
                       NIL NIL NBYTES)
                (replace (M44STREAM LastPage) of STREAM with LASTPAGE#)
                (replace (M44STREAM LastOffset) of STREAM with NBYTES])
)



(* ;; "Disk allocation")

(DEFINEQ

(\ADDDISKPAGES
  [LAMBDA (STREAM FIRSTNEWPAGE NPAGES DAs LASTNUMCHARS)  (* ; "Edited 21-Jan-91 23:42 by jds")

    (* ;; "Adds to file STREAM NPAGES, where FIRSTNEWPAGE-1 is the last existing page.  DAs is the vector of disk addresses, where first element corresponds to BFS page -1")
                                                             (* ; 
                    "Note FIRSTNEWPAGE is in Lisp terms, so it is actually LASTOLDPAGE for the BFS")
    (PROG ((LASTPAGEBUF (NCREATE 'VMEMPAGEP))
           (LASTEXISTINGPAGE FIRSTNEWPAGE)
           (DSK (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)))
           BUFFERS CHUNK)
          (SETQ BUFFERS (CONS LASTPAGEBUF (for I from 1 to (IMIN NPAGES \MAXDISKDAs)
                                             collect NIL)))
          (\ACTONDISKPAGES DSK LASTPAGEBUF DAs -1 STREAM LASTEXISTINGPAGE LASTEXISTINGPAGE \DC.READD
                 NIL NIL NIL LASTEXISTINGPAGE)               (* ; 
                                     "Read last existing page, so we can rewrite it with new label")
          (while (IGREATERP NPAGES 0) do (SETQ CHUNK (IMIN \MAXDISKDAs NPAGES))
                                                (\WRITEDISKPAGES DSK BUFFERS DAs -1 STREAM 
                                                       LASTEXISTINGPAGE (IPLUS LASTEXISTINGPAGE CHUNK
                                                                               )
                                                       NIL NIL LASTNUMCHARS LASTEXISTINGPAGE)
                                                (RPLACA BUFFERS NIL)
                                                (add LASTEXISTINGPAGE CHUNK)
                                                (SETQ NPAGES (IDIFFERENCE NPAGES CHUNK])

(\M44DELETEPAGES
  [LAMBDA (STREAM FIRSTPAGE)                             (* ; "Edited 21-Jan-91 23:42 by jds")
                                                             (* ; 
                                               "FIRSTPAGE is in Lisp terms, i.e.  -1 = leader page")
    (PROG ((DEV (fetch DEVICE of STREAM))
           (NPAGES (COND
                      ((fetch VALIDATION of STREAM)
                       (IPLUS (ADD1 (IDIFFERENCE (fetch (M44STREAM LastPage) of STREAM)
                                           FIRSTPAGE))
                              2))
                      (T PageMapIncrement)))
           (PN (ADD1 FIRSTPAGE))
           DAs FIRSTDA LASTPAGESEEN DSK)

     (* ;; "NPAGES is used to decide how much to do at once.  Need be no more than number of pages known to exist.  The ADD1 is that, plus two for the pages around it")

          (COND
             ((ILESSP NPAGES 2)                              (* ; "Nothing to delete")
              (RETURN)))
          (SETQ DSK (fetch (M44DEVICE DSKOBJ) of DEV))
                                                             (* (\FLUSHDISKDESCRIPTOR
                                                           (EMPOINTER (fetch (DSKOBJ DSKDDMGR) 
                                                           of DSK)) (fetch (DSKOBJ ALTODSKOBJ) 
                                                           of DSK)))
                                                             (* ; 
                                                "Tell Alto to clear out anything it knows about dd")
                                                             (* ; 
         "IF STREAM:LASTMAPPEDPAGE GE FIRSTPAGE+NPAGES THEN DAs _ STREAM:FILEPAGEMAP DAorigin _ -1")
          (SETQ DAs (ARRAY (SETQ NPAGES (IMIN NPAGES \MAXDISKDAs))
                           'WORD NIL 0))
          [SETQ FIRSTDA (COND
                           [(EQ FIRSTPAGE -1)
                            (fetch (FP FPLEADERVDA) of (fetch (FID FIDBLOCK)
                                                                  of (fetch (M44STREAM FID)
                                                                            of STREAM]
                           (T (\M44GetPageLoc STREAM FIRSTPAGE]
          (while (NEQ FIRSTDA \EOFDA)
             do (SETA DAs 0 \FILLINDA)
                   (SETA DAs 1 FIRSTDA)                      (* ; "Corresponds to PN")
                   (for I from 2 to (SUB1 NPAGES) do (SETA DAs I \FILLINDA))
                   [SETQ LASTPAGESEEN (\ACTONDISKPAGES DSK NIL (fetch (ARRAYP BASE) of DAs)
                                             (SUB1 PN)
                                             STREAM PN (IPLUS PN NPAGES -3)
                                             \DC.READD NIL NIL NIL (ADD1 (fetch EPAGE
                                                                            of STREAM] 
                                                             (* ; "Read DAs for the next NPAGES-2")
                   (\WRITEDISKPAGES DSK NIL (fetch (ARRAYP BASE) of DAs)
                          (SUB1 PN)
                          \FREEPAGEFID PN LASTPAGESEEN (UNSIGNED -1 BITSPERWORD))
                   [for I from PN to LASTPAGESEEN
                      do (\M44MARKPAGEFREE DEV (ELT DAs (ADD1 (IDIFFERENCE I PN]
                   (SETQ FIRSTDA (ELT DAs (IPLUS (IDIFFERENCE LASTPAGESEEN PN)
                                                 2)))
                   (SETQ PN (ADD1 LASTPAGESEEN)))            (* (FLUSHMAP (fetch
                                                           (M44DEVICE DISKDESCRIPTOROFD) of DEV))
                                                           (FORGETPAGES (fetch
                                                           (M44DEVICE DISKDESCRIPTOROFD) of DEV)))
          (\M44FLUSHDISKDESCRIPTOR DEV])

(\ASSIGNDISKPAGE
  [LAMBDA (DSK PREVDA)                                   (* ; "Edited 21-Jan-91 23:32 by jds")

(* ;;; "Assigns a new page on DSK.  If PREVDA is \EOFDA will pick random page, otherwise will attempt to allocate PREVDA+1.  Returns NIL if disk is full")

    (PROG ([VDA (COND
                   ((OR (EQ PREVDA \EOFDA)
                        (COND
                           ((EQ PREVDA \FILLINDA)
                            (AND \DISKDEBUG (RAID 
                                "[Disk debug] \ASSIGNDISKPAGE called with \FILLINDA.  ^N to continue"
                                                  ))
                            T)))
                    (fetch (DSKOBJ DISKLASTPAGEALLOC) of DSK))
                   (T (ADD1 PREVDA]
           (DD (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSK))
           (MASK 128)
           BITS A LOOPEDONCE FREE)
          (OR (fetch (DSKOBJ DDVALID) of DSK)
              (RAID "DISKDESCRIPTOR not open" DSK))
          (\SETFILEPTR DD (IPLUS \DDBITTABSTART (FOLDLO VDA BITSPERBYTE)))
          (SETQ A (MOD VDA BITSPERBYTE))
          (FRPTQ A (SETQ MASK (LRSH MASK 1)))
      LP  (COND
             ((NULL (SETQ BITS (\BIN DD)))

              (* ;; "End of file -- wrap around to start.  This technique takes longer than necessary to bomb out when disk is full, but who cares?")

              (COND
                 (LOOPEDONCE (RETURN NIL)))
              (SETQ LOOPEDONCE T)
              (\SETFILEPTR DD \DDBITTABSTART))
             ((NEQ BITS 255)
              (until (OR (EQ (LOGAND BITS MASK)
                                 0)
                             (EQ (SETQ MASK (LRSH MASK 1))
                                 0)) do (add A 1))
              (COND
                 ((NEQ MASK 0)                               (* ; "Found a free page")
                  (\BACKFILEPTR DD)
                  (SETQ VDA (IPLUS (UNFOLD (IDIFFERENCE (\GETFILEPTR DD)
                                                  \DDBITTABSTART)
                                          BITSPERBYTE)
                                   A))
                  (\BOUT DD (LOGOR BITS MASK))               (* ; 
                                                          "Set bit indicating we snarfed this page")
                                                             (* ; "Decrement free page count hint")
                  [replace (DSKOBJ DISKFREEPAGES) of DSK
                     with (COND
                                 ((EQ (SETQ FREE (fetch (DSKOBJ DISKFREEPAGES) of DSK))
                                      0)
                                  (AND \DISKDEBUG (RAID 
                                         "[Disk debug] Free page hint went negative.  ^N to continue"
                                                        ))
                                  (\COUNTDISKFREEPAGES DD))
                                 (T (SUB1 FREE]
                  (replace (DSKOBJ DISKLASTPAGEALLOC) of DSK with VDA)
                  (replace (DSKOBJ DDDIRTY) of DSK with T)
                  (RETURN VDA)))
              (SETQ MASK 128)
              (SETQ A 0)))
          (GO LP])

(\COUNTDISKFREEPAGES
(LAMBDA (DD) (* bvm%: "13-Feb-85 19:32") (* ;;; "Counts number of free pages on a disk.  DD is the diskdescriptor stream") (OR (type? STREAM DD) (SETQ DD (\OPENDISKDESCRIPTOR (\GETDEVICEFROMNAME (OR DD (QUOTE DSK)))))) (PROG ((CNT 0) MASK BITS) (\SETFILEPTR DD \DDBITTABSTART) LP (COND ((NULL (SETQ BITS (\BIN DD))) (* ; "End of file") (RETURN CNT)) ((EQ BITS 0) (add CNT 8)) ((NEQ BITS 255) (SETQ MASK 128) (do (COND ((EQ (LOGAND BITS MASK) 0) (add CNT 1))) until (EQ (SETQ MASK (LRSH MASK 1)) 0)))) (GO LP)))
)

(\M44MARKPAGEFREE
(LAMBDA (DEV DA) (* bvm%: "17-Jan-85 17:11") (* ;; "Mark disk address DA on disk device DEV free") (PROG ((DSK (COND ((type? FDEV DEV) (fetch (M44DEVICE DSKOBJ) of DEV)) (T DEV))) DD BITS MASK) (SETQ DD (COND ((fetch (DSKOBJ DDVALID) of DSK) (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSK)) (T (\OPENDISKDESCRIPTOR DEV)))) (SETFILEPTR DD (IPLUS \DDBITTABSTART (FOLDLO DA BITSPERBYTE))) (SETQ BITS (\BIN DD)) (SETQ MASK (LLSH 1 (IDIFFERENCE 7 (MOD DA BITSPERBYTE)))) (COND ((NEQ (LOGAND BITS MASK) 0) (* ; "Page is marked occupied, so free it") (\BACKFILEPTR DD) (\BOUT DD (LOGXOR BITS MASK)) (add (fetch (DSKOBJ DISKFREEPAGES) of DSK) 1) (replace (DSKOBJ DDDIRTY) of DSK with T)))))
)

(\M44FLUSHDISKDESCRIPTOR
  [LAMBDA (DEV)                                          (* ; "Edited 21-Jan-91 23:32 by jds")
    (PROG ((DSK (COND
                   ((type? FDEV DEV)
                    (fetch (M44DEVICE DSKOBJ) of DEV))
                   (T DEV)))
           DD)
          (OR (fetch (DSKOBJ DDDIRTY) of DSK)
              (RETURN))
          (OR (SETQ DD (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSK))
              (RETURN (RAID "[Disk debug] no disk descriptor stream")))
          (\SETFILEPTR DD \OFFSET.DISKLASTSERIAL#)
          (\BOUTS DD (LOCF (fetch (DSKOBJ DISKLASTSERIAL#) of DSK))
                 0 \NBYTES.DISKINFO)                         (* ; 
                                                "Copy interesting stuff into diskdescriptor header")
          (FORCEOUTPUT DD)
          (replace (DSKOBJ DDDIRTY) of DSK with NIL)
          (RETURN T])

(\MAKELEADERDAS
  [LAMBDA (STREAM)                                       (* ; "Edited 21-Jan-91 23:30 by jds")

    (* ;; "Makes a page map for STREAM that includes the leader vda")

    (PROG ((MAP (ARRAY 4 'WORD \FILLINDA 0)))
          (SETA MAP 0 \EOFDA)
          [SETA MAP 1 (fetch (FP FPLEADERVDA) of (fetch (ARRAYP BASE)
                                                            of (fetch (M44STREAM FID)
                                                                      of STREAM]
          (replace (M44STREAM FILEPAGEMAP) of STREAM with MAP)
          (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with -1)
          (RETURN MAP])

(DISKFREEPAGES
(LAMBDA (DSK RECOMPUTE) (* ejs%: " 7-Nov-85 16:33") (* ; "DSK ignored for now") (SELECTC \MACHINETYPE ((LIST \DANDELION \DAYBREAK) (* ; "Temporary until this become a device op") (\DFSFreeDiskPages DSK RECOMPUTE)) (\M44FREEPAGECOUNT (COND ((type? FDEV DSK) DSK) (T (\GETDEVICEFROMNAME (OR DSK (QUOTE DSK))))) NIL RECOMPUTE)))
)

(\M44FREEPAGECOUNT
(LAMBDA (DEV DIRECTORY RECOMPUTE) (* bvm%: "12-Oct-85 15:43") (PROG (CNT) (COND ((NOT (type? M44DEVICE DEV)) (\ILLEGAL.ARG DEV))) (RETURN (COND (RECOMPUTE (SETQ CNT (\COUNTDISKFREEPAGES (\OPENDISKDESCRIPTOR DEV))) (COND ((NEQ CNT (fetch (M44DEVICE DISKFREEPAGES) of DEV)) (replace (M44DEVICE DISKFREEPAGES) of DEV with CNT) (replace (M44DEVICE DDDIRTY) of DEV with T))) CNT) (T (fetch (M44DEVICE DISKFREEPAGES) of DEV))))))
)

(VMEMSIZE
(LAMBDA NIL (* bvm%: " 1-NOV-82 16:44") (fetch (IFPAGE NActivePages) of \InterfacePage)))
)

(RPAQ? \M44MULTFLG T)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS UCASECHAR MACRO [(C)
                                   (COND
                                      ((ILESSP C (CHARCODE a))
                                       C)
                                      (T (IDIFFERENCE C (IDIFFERENCE (CHARCODE a)
                                                               (CHARCODE A])

(PUTPROPS UPDATEVALIDATION MACRO [(STREAM BUF)
                                          (replace VALIDATION of STREAM
                                             with (\MAKENUMBER (\GETBASE BUF 1)
                                                             (\GETBASE BUF 3])
)

(DECLARE%: EVAL@COMPILE

(ACCESSFNS M44DEVICE ((DSKOBJ (fetch DEVICEINFO of DATUM)
                                 (replace DEVICEINFO of DATUM with NEWVALUE)))
                         [TYPE? (AND (type? FDEV DATUM)
                                         (EQ (fetch OPENFILE of DATUM)
                                             '\M44OpenFile])
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \OPENFILES \M44MULTFLG \DISKNAMECASEARRAY)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS .LISP.TO.BFS. MACRO (= . ADD1))

(PUTPROPS .BFS.TO.LISP. MACRO (= . SUB1))

(PUTPROPS .DISKCASEARRAY. MACRO [NIL (fetch (ARRAYP BASE) of (\DTEST 
                                                                                   \DISKNAMECASEARRAY
                                                                                    'ARRAYP])
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ PageMapIncrement 64)

(RPAQQ \MAX.ALTO.NAME.LENGTH 39)


(CONSTANTS (PageMapIncrement 64)
       (\MAX.ALTO.NAME.LENGTH 39))
)




(* ;; "File properties")

(DECLARE%: EVAL@COMPILE

(BLOCKRECORD M44FILEPROP ((FPROPTYPE BYTE)               (* ; "Type of property")
                              (FPROPLENGTH BYTE)             (* ; "Length of entire entry in words")
                              (FPROPWORD0 WORD)              (* ; "value starts here")
                              )                              (* ; 
                                      "Overlays a piece of leader page to describe a file property")
                             )
)

(RPAQQ FPROPTYPES ((\FPROP.TYPE 136)
                       (\FPROP.PAGEMAP 137)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \FPROP.TYPE 136)

(RPAQQ \FPROP.PAGEMAP 137)


(CONSTANTS (\FPROP.TYPE 136)
       (\FPROP.PAGEMAP 137))
)

(RPAQQ FPTYPES ((\FPTYPE.UNKNOWN 0)
                    (\FPTYPE.TEXT 1)
                    (\FPTYPE.BINARY 2)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \FPTYPE.UNKNOWN 0)

(RPAQQ \FPTYPE.TEXT 1)

(RPAQQ \FPTYPE.BINARY 2)


(CONSTANTS (\FPTYPE.UNKNOWN 0)
       (\FPTYPE.TEXT 1)
       (\FPTYPE.BINARY 2))
)

(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTDEF '\M44PAGEBUFFER 'RESOURCES '(NEW (NCREATE 'VMEMPAGEP]
)
)

(/SETTOPVAL '\\M44PAGEBUFFER.GLOBALRESOURCE NIL)
)

(/SETTOPVAL '\\M44PAGEBUFFER.GLOBALRESOURCE NIL)



(* ;; "Directory enumeration")

(DEFINEQ

(\M44GENERATEFILES
(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* bvm%: "12-Oct-85 15:13") (* ;; "Returns a file-generator object that will generate AT LEAST all files in the sys-dir of FDEV whose names match PATTERN.  Clients might need to provide additional filtering.  For M44, the generate state consists of the HOSTNAME (DSK) followed by a 'search state' , a directory pointer and a character list of the sort that \SEARCHDIR1 expects.  DIRPTR is the position of the next file to be considered in the directory.") (PROG ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of FDEV)) (SORT? (EQMEMB (QUOTE SORT) OPTIONS)) (CASEBASE (.DISKCASEARRAY.)) (EXT (QUOTE *)) HOSTNAME NAME VERSION CHARLIST GENSTREAM FILTER DESIREDVERSION SEARCHSTATE HOSTPREFIX) (OR DIRSTREAM (RETURN (\NULLFILEGENERATOR))) (COND ((for TAIL on (UNPACKFILENAME.STRING PATTERN) by (CDDR TAIL) do (SELECTQ (CAR TAIL) (HOST (SETQ HOSTNAME (CADR TAIL))) (NAME (SETQ NAME (CADR TAIL))) (EXTENSION (SETQ EXT (CADR TAIL))) (VERSION (COND ((OR (EQ (NCHARS (SETQ VERSION (MKATOM (CADR TAIL)))) 0) (EQ VERSION 0)) (* ; "Newest version only") (SETQ SORT? T) (* ; "Can only get highest version by sorting") (SETQ VERSION NIL) (SETQ DESIREDVERSION T)) ((SMALLP VERSION) (* ; "An actual specific version to look for") (SETQ DESIREDVERSION VERSION)) ((NEQ VERSION (QUOTE *)) (* ; "Bogus version") (RETURN T)))) (RETURN T))) (* ; "Bad file name") (RETURN (\NULLFILEGENERATOR)))) (SETQ FILTER (DIRECTORY.MATCH.SETUP (CONCAT NAME (QUOTE %.) EXT ";*"))) (SETQ CHARLIST (for C instring (COND ((OR (EQ 0 (NCHARS EXT)) (EQ (CHCON1 EXT) (CHARCODE *))) NAME) (T (CONCAT NAME (QUOTE %.) EXT))) until (SELCHARQ (SETQ C (\GETBASEBYTE CASEBASE C)) ((%# *) (* ;; "\SEARCHDIR1 currently only checks prefixes, so we truncate at the first * or escape.  Also ignore version specifications, because of the alternative representations of version 1") T) NIL) collect C)) (COND (DESIREDPROPS (* ; "Create a scratch stream for \M44FILEINFOFN to use") (SETQ GENSTREAM (create M44STREAM)) (replace DEVICE of GENSTREAM with FDEV))) (SETQ SEARCHSTATE (create M44DIRSEARCHSTATE DIRPTR _ 0 CHARLIST _ CHARLIST)) (SETQ HOSTPREFIX (CONCAT (QUOTE {) HOSTNAME (QUOTE }))) (RETURN (COND (SORT? (* ; "Have to generate the matching files first, sort them, then enumerate") (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \M44SORTEDNEXTFILEFN) FILEINFOFN _ (FUNCTION \M44FILEINFOFN) GENFILESTATE _ (create M44GENFILESTATE DIROFD _ DIRSTREAM SEARCHSTATE _ (\M44SORTFILES DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX (LENGTH CHARLIST)) GENVERSION _ DESIREDVERSION GENSTREAM _ GENSTREAM))) (T (* ; "Order not important") (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \M44NEXTFILEFN) FILEINFOFN _ (FUNCTION \M44FILEINFOFN) GENFILESTATE _ (create M44GENFILESTATE DIROFD _ DIRSTREAM SEARCHSTATE _ SEARCHSTATE GENFILTER _ FILTER GENVERSION _ DESIREDVERSION HOSTNAME _ HOSTPREFIX GENSTREAM _ GENSTREAM)))))))
)

(\M44SORTFILES
(LAMBDA (DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH) (* bvm%: " 7-Jun-84 14:38") (SORT (bind FL while (SETQ FL (\M44GENERATENEXT DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH)) collect FL) (FUNCTION (LAMBDA (X Y) (SELECTQ (UALPHORDER (CAR X) (CAR Y)) (LESSP T) (EQUAL (IGREATERP (CADR X) (CADR Y))) NIL)))))
)

(\M44GENERATENEXT
  [LAMBDA (DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH GENFILESTATE)
                                                             (* ; "Edited 21-Jan-91 23:53 by jds")

(* ;;; "Produces the next filename from directory DIRSTREAM satisfying SEARCHSTATE and the more constrained FILTER and DESIREDVERSION, or returns NIL if no more files.  HOSTPREFIX is string to put on front, or NIL for names only.  PATTERNLENGTH is the length of the pattern in SEARCHSTATE.  GENFILESTATE is a a M44GENFILESTATE whose GENSTREAM and ENTRYSTART want to be set appropriately for \M44FILEINFOFN;  if NIL, then the value is returned for SORTFILES in the form (name version entrystart)")

    (PROG ((PATTERNHASDOT (MEMB (CHARCODE %.)
                                (fetch (M44DIRSEARCHSTATE CHARLIST) of SEARCHSTATE)))
           SAWDOT ENTRYSTART TEMP PREFIXLEN TOTALLEN THISVERSION RESULT INDEX)
      LP  (COND
             ((NOT (SETQ TEMP (\M44SEARCHDIR DIRSTREAM SEARCHSTATE)))
                                                             (* ; "Enumeration finished")
              (RETURN NIL)))
          (SETQ SAWDOT PATTERNHASDOT)
          (SETQ ENTRYSTART (IDIFFERENCE (GETFILEPTR DIRSTREAM)
                                  (IPLUS PATTERNLENGTH 13))) (* ; 
                                                       "Read all the characters from the directory")
          (SETQ TOTALLEN (IPLUS PATTERNLENGTH (SUB1 TEMP)))
          (for I from (SUB1 TEMP) to 1 by -1
             do                                          (* ; 
                                      "The SUB1 is because the last character is the undesired dot")
                   (SELCHARQ (\BIN DIRSTREAM)
                        (! [RETURN (SETQ THISVERSION (\M44READVERSION DIRSTREAM (SUB1 I])
                        (%. (SETQ SAWDOT T))
                        NIL) finally (SETQ THISVERSION 1))
          (COND
             ((AND DESIREDVERSION (NEQ THISVERSION DESIREDVERSION)
                   (NEQ DESIREDVERSION T))                   (* ; "Failure, try next")
              (GO LP)))
          [SETQ RESULT (ALLOCSTRING (IPLUS TOTALLEN (SETQ PREFIXLEN (COND
                                                                       (HOSTPREFIX (NCHARS HOSTPREFIX
                                                                                          ))
                                                                       (T 0)))
                                           (COND
                                              ((AND (EQ THISVERSION 1)
                                                    HOSTPREFIX)
                                               2)
                                              (T 0))
                                           (COND
                                              (SAWDOT 0)
                                              (T 1]
          (AND HOSTPREFIX (RPLSTRING RESULT 1 HOSTPREFIX))
          (\SETFILEPTR DIRSTREAM (IPLUS ENTRYSTART 13))      (* ; "Now read the whole name")
          (SETQ INDEX PREFIXLEN)
          (for I from TOTALLEN to 1 by -1
             do (SELCHARQ (SETQ TEMP (\BIN DIRSTREAM))
                         (%. (SETQ SAWDOT T))
                         (! (OR SAWDOT (RPLCHARCODE RESULT (add INDEX 1)
                                              (CHARCODE %.)))
                            (SETQ SAWDOT T)
                            [COND
                               (HOSTPREFIX (RPLCHARCODE RESULT (add INDEX 1)
                                                  (CHARCODE ;))
                                      (to (SUB1 I)
                                         do (RPLCHARCODE RESULT (add INDEX 1)
                                                       (COND
                                                          (GENFILESTATE (\BIN DIRSTREAM))
                                                          (T 

                                 (* ;; "Make everything a constant version for benefit of SORT.  Will replace with real thing later.  The constant version is chosen in a way that makes 2-digit versions sort in front of 1-digit versions, etc, and single-digit versions come out as ;1 to match the ;1 inserted below")

                                                             (IDIFFERENCE (CHARCODE 3)
                                                                    I]
                            (RETURN))
                         NIL)
                   (RPLCHARCODE RESULT (add INDEX 1)
                          TEMP))
          (OR SAWDOT (RPLCHARCODE RESULT (add INDEX 1)
                            (CHARCODE %.)))
          (COND
             ((AND (EQ THISVERSION 1)
                   HOSTPREFIX)
              (RPLSTRING RESULT (ADD1 INDEX)
                     ";1")))
          (COND
             ((AND FILTER (NOT (DIRECTORY.MATCH FILTER RESULT)))
              (GO LP)))
          (RETURN (COND
                     (GENFILESTATE (replace (M44GENFILESTATE ENTRYSTART) of GENFILESTATE
                                      with ENTRYSTART)
                            (replace (M44STREAM DIRINFO) of (fetch (M44GENFILESTATE
                                                                                GENSTREAM)
                                                                       of GENFILESTATE)
                               with NIL)
                            RESULT)
                     (T (LIST RESULT THISVERSION ENTRYSTART])

(\M44NEXTFILEFN
  [LAMBDA (GENFILESTATE NAMEONLY)                        (* ; "Edited 21-Jan-91 23:53 by jds")

    (* ;; "GENFILESTATE is the state information from the file-generator object created by \M44GENERATEFILES.  This function returns the next file name as a string.  Returns NIL if no files left.  It updates GENFILESTATE so that it will get the following satisfactory file on the next call to this function.  --- NAMEONLY => returns the filenames without the semi-colon and version number")

    (PROG ((DIRSTREAM (fetch (M44GENFILESTATE DIROFD) of GENFILESTATE))
           (SEARCHSTATE (fetch (M44GENFILESTATE SEARCHSTATE) of GENFILESTATE))
           (DESIREDVERSION (fetch (M44GENFILESTATE GENVERSION) of GENFILESTATE))
           (FILTER (fetch (M44GENFILESTATE GENFILTER) of GENFILESTATE))
           (HOSTPREFIX (AND (NOT NAMEONLY)
                            (fetch (M44GENFILESTATE HOSTNAME) of GENFILESTATE)))
           PATTERNLENGTH)
          (SETQ PATTERNLENGTH (LENGTH (fetch (M44DIRSEARCHSTATE CHARLIST) of SEARCHSTATE)))
          (RETURN (\M44GENERATENEXT DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX 
                         PATTERNLENGTH GENFILESTATE])

(\M44SORTEDNEXTFILEFN
  [LAMBDA (GENFILESTATE NAMEONLY)                        (* ; "Edited 21-Jan-91 23:51 by jds")
    (LET ((FILES (fetch (M44GENFILESTATE SEARCHSTATE) of GENFILESTATE))
          THISFILE THISNAME V LEN)
         (COND
            ((SETQ THISFILE (CAR FILES))                     (* ; 
                                                           "THISFILE = (name version entryStart)")
             (SETQ THISNAME (CAR THISFILE))
             (SETQ V (CADR THISFILE))

             (* ;; "need to fill in the correct version number, since the names were generated with constant version number")

             (SETQ LEN (NCHARS THISNAME))
             [COND
                [(ILESSP V 10)                               (* ; "Easy, 1-digit version")
                 (\RPLCHARCODE THISNAME LEN (PLUS V (CHARCODE 0]
                (T (SETQ V (CHCON V))
                   (for C in V as I from [SETQ LEN (ADD1 (IDIFFERENCE LEN
                                                                                (LENGTH V]
                      do (\RPLCHARCODE THISNAME I C]
             (replace (M44STREAM DIRINFO) of (fetch (M44GENFILESTATE GENSTREAM)
                                                        of GENFILESTATE) with NIL)
             (replace (M44GENFILESTATE ENTRYSTART) of GENFILESTATE with (CADDR THISFILE))
             (SETQ FILES (CDR FILES))
             (COND
                ((EQ (fetch (M44GENFILESTATE GENVERSION) of GENFILESTATE)
                     T)
                 (bind (THISNAMEONLY _ (SUBSTRING THISNAME 1 (SUB1 LEN)))
                    while (AND FILES (STRING-EQUAL (SUBSTRING (CAAR FILES)
                                                              1
                                                              (SUB1 LEN))
                                                THISNAMEONLY)) do (SETQ FILES (CDR FILES)))
                 FILES))
             (replace (M44GENFILESTATE SEARCHSTATE) of GENFILESTATE with FILES)
             THISNAME])

(\M44FILEINFOFN
  [LAMBDA (GENFILESTATE ATTRIBUTE)                       (* ; "Edited 21-Jan-91 23:51 by jds")

    (* ;; 
 "Retrieves info of file currently being enumerated.  State has a directory pointer to help us out")

    (PROG ((STREAM (fetch (M44GENFILESTATE GENSTREAM) of GENFILESTATE)))
          (OR STREAM (RETURN))
          (COND
             ((NULL (fetch (M44STREAM DIRINFO) of STREAM))
              (replace VALIDATION of STREAM with (replace (M44STREAM FILEPAGEMAP)
                                                                of STREAM with NIL))
              (replace (M44STREAM DIRINFO) of STREAM with (fetch (M44GENFILESTATE
                                                                                  ENTRYSTART)
                                                                         of GENFILESTATE))
              (replace (M44STREAM FID) of STREAM with (\M44READDIRFID
                                                                   (fetch (M44GENFILESTATE DIROFD
                                                                                     ) of 
                                                                                         GENFILESTATE
                                                                          )
                                                                   (fetch (M44GENFILESTATE 
                                                                                     ENTRYSTART)
                                                                      of GENFILESTATE)
                                                                   (fetch (M44STREAM FID)
                                                                      of STREAM)))
              (\M44ReadLeaderPage STREAM T)))
          (RETURN (\M44GetFileInfo STREAM ATTRIBUTE])
)



(* ;; "Directory lookup routines")

(DEFINEQ

(\M44PARSEFILENAME
  [LAMBDA (X RECOG DEV CREATEFLG)                        (* ; "Edited 21-Jan-91 23:47 by jds")

    (* ;; "This returns a full file specification, with all the information needed to do open, delete, etc.  A filespec is a (uname dirptr) pair, with the true version number smashed into the uname.  The dirptr is NIL if the file does not currently exist in the directory.")

    (PROG ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of DEV))
           UNAME ENDNAMEOFFSET MAYBENEW EXPLICITVERSION FIXEDVERSION UCHARS SOMEPTR TLIST PTR 
           NCHARSLEFT BESTVERSION BESTPTR VERS HMIN OLDESTP)
          [COND
             ([NULL (SETQ UNAME (\M44UNPACKFILENAME X DEV (SELECTQ RECOG
                                                                  ((NEW OLD/NEW) 
                                                             (* ; 
                 "We might create a new file here, so tell unpack to save the original characters.")
                                                                       (SETQ MAYBENEW T))
                                                                  NIL]
                                                             (* ; "BAD FILE NAME")
              (RETURN (create FILESPEC
                             UNAME _ NIL]

     (* ;; "Name parsed ok, get ready to search directory for it.")

          (SETQ UCHARS (fetch (UNAME UCASECHARS) of UNAME))
          (SETQ ENDNAMEOFFSET (+ 13 (LENGTH UCHARS)))        (* ; "ENDNAMEOFFSET is length of name we're searching for plus fixed overhead (header word, FID, name length byte)")
          [COND
             (CREATEFLG                                      (* ; "Want to look for a hole, in case we need to create the file.  The 6 is to allow for the maximum number of chars in a version number")
                    (SETQ HMIN (FOLDLO (+ ENDNAMEOFFSET 6)
                                      BYTESPERWORD]
          (SETQ TLIST (CONS 0 UCHARS))                       (* ; 
                                    "Pair of dirptr & chars used to communicate with \M44SEARCHDIR")
          (if (AND (FIXP (SETQ EXPLICITVERSION (fetch (UNAME VERSION) of UNAME)))
                       (NEQ EXPLICITVERSION 0))
              then                                       (* ; 
        "If caller gave a real explicit version, then if we find that version, we know we're done.")
                    (SETQ FIXEDVERSION EXPLICITVERSION))
          (SETQ OLDESTP (EQ (OR EXPLICITVERSION RECOG)
                            'OLDEST))
      SEARCHLP
          (COND
             ((NULL (SETQ NCHARSLEFT (\M44SEARCHDIR DIRSTREAM TLIST HMIN)))
                                                             (* ; "No more prefix matches found")
              (GO DONE)))
          (SETQ PTR (\GETFILEPTR DIRSTREAM))                 (* ; "Note current position")
          (COND
             ((EQ NCHARSLEFT 1)                              (* ; 
                        "No version, just the final dot remains, so we must have matched version 1")
              (SETQ VERS 1))
             ((NEQ (\BIN DIRSTREAM)
                   (CHARCODE !))                             (* ; 
                                                    "More chars follow before version, so no match")
              (GO NEXT))
             ([NULL (SETQ VERS (\M44READVERSION DIRSTREAM (- NCHARSLEFT 2]
              (GO NEXT)))

     (* ;; "Name matches.  VERS is the version number.  Is it better than we've seen?  Accumulate extreme vers,ptr in BESTVERSION,BESTPTR.")

          (SETQ PTR (- PTR ENDNAMEOFFSET))                   (* ; 
                                                           "Beginning of the directory entry")
          (COND
             [FIXEDVERSION                                   (* ; "Version must match")
                    (SETQ BESTPTR PTR)                       (* ; 
                                        "Always note a pointer, for benefit of getting case right.")
                    (COND
                       ((EQ VERS FIXEDVERSION)               (* ; "The one we've been looking for")
                        (SETQ BESTVERSION VERS)
                        (GO DONE]
             ((OR (NULL BESTVERSION)
                  (if OLDESTP
                      then (< VERS BESTVERSION)
                    else (> VERS BESTVERSION)))          (* ; "More extreme than the last one")
              (SETQ BESTVERSION VERS)
              (SETQ BESTPTR PTR)))
      NEXT
          (COND
             ((AND HMIN (fetch (M44STREAM DIRHOLEPTR) of DIRSTREAM))
                                                             (* ; 
                                                           "Stop looking for a hole if found one")
              (SETQ HMIN NIL)))
          (GO SEARCHLP)
      DONE
          

     (* ;; "At this point, BESTVERSION is the version, if any, that best matches RECOG or funny version spec in UNAME, i.e., it is the oldest or newest version.  BESTPTR is the corresponding directory pointer.  In the case where an explicit version was requested but not found, BESTPTR is the directory pointer of SOME version.  So now we need to bump the version up for RECOG = NEW, and maybe adjust the characters.")

          (SETQ SOMEPTR BESTPTR)                             (* ; 
                                        "Save dir pointer for getting at true chars for new files.")
          (if BESTVERSION
              then                                       (* ; "Found one")
                    (if (if EXPLICITVERSION
                                then                     (* ; "Ignore funny version N when asking for %"OLD%" recognition--don't want FOO;N to mean next highest version, since that's a lie. e.g., it's not infilep.")
                                      (AND (EQ EXPLICITVERSION 'NEW)
                                           MAYBENEW)
                              else (EQ RECOG 'NEW))
                        then (add BESTVERSION 1)     (* ; 
                                     "Bump version, clear directory pointer (since we're creating)")
                              (SETQ BESTPTR NIL))
            elseif MAYBENEW
              then                                       (* ; 
                                     "Specified file doesn't exist, but we're willing to create it")
                    (SETQ BESTVERSION (OR FIXEDVERSION 1))
                    (SETQ BESTPTR NIL))
          (RETURN (if BESTVERSION
                      then                               (* ; "Success")
                            (if (NULL BESTPTR)
                                then                     (* ; 
                                     "New file.  Get the case right if some other version existed.")
                                      (if SOMEPTR
                                          then (replace (UNAME ORIGCHARS) of UNAME
                                                      with (\M44READDIRNAME DIRSTREAM SOMEPTR
                                                                      )))
                              elseif (fetch (UNAME ORIGCHARS) of UNAME)
                                then                     (* ; 
  "New recog but existing file--happens when overwriting.  Still want to get the characters right.")
                                      (replace (UNAME ORIGCHARS) of UNAME
                                         with (\M44READDIRNAME DIRSTREAM BESTPTR)))
                            (replace (UNAME VERSION) of UNAME with BESTVERSION)
                            (create FILESPEC
                                   UNAME _ UNAME
                                   FSDIRPTR _ BESTPTR])

(\FINDDIRHOLE
  [LAMBDA (NWORDS DIRSTREAM)                             (* ; "Edited 21-Jan-91 23:37 by jds")

    (* ;; "Returns the byte address of a directory hole of size NWORDS.  The directory file is positioned just after the 2-byte length field of the hole.")

    (PROG ((HINT (fetch (M44STREAM DIRHOLEPTR) of DIRSTREAM))
           PTR ENTRYLENGTH C)
          (SETQ PTR (OR HINT 0))
      NEXT
          (\SETFILEPTR DIRSTREAM PTR)
          (COND
             ((\EOFP DIRSTREAM)
              (if (AND HINT (> HINT 0))
                  then                                   (* ; 
                                                           "Hint failed, so try from the start.")
                        (SETQ HINT NIL)
                        (SETQ PTR 0)
                        (GO NEXT)
                else (GO END)))
             ((AND (>= (SETQ ENTRYLENGTH (+ (LLSH (LOGAND (SETQ C (\BIN DIRSTREAM))
                                                         3)
                                                  8)
                                            (\BIN DIRSTREAM)))
                       NWORDS)
                   (< C 4))

              (* ;; "First 6 bits is entry type, next 10 bits are length of entry in words.  Free entries have type zero.  Thus C < 4 implies this is free entry.")

              (\SETFILEPTR DIRSTREAM PTR)                    (* ; "Hole is large enough")
              [COND
                 ((> ENTRYLENGTH NWORDS)                     (* ; 
                "Too large, so split hole into 2 parts.  We'll return the second half of the hole.")
                  (\WOUT DIRSTREAM (SETQ ENTRYLENGTH (- ENTRYLENGTH NWORDS)))
                  (\SETFILEPTR DIRSTREAM (add PTR (UNFOLD ENTRYLENGTH BYTESPERWORD]
              (GO END)))
          (add PTR (UNFOLD ENTRYLENGTH BYTESPERWORD))
          (GO NEXT)
      END (\WOUT DIRSTREAM NWORDS)
          (RETURN PTR])

(\M44PACKFILENAME
(LAMBDA (UNAME DIRPTR DIRSTREAM) (* ; "Edited 12-Jan-88 12:01 by bvm") (* ;; "Produces a Lisp style file-name of the form 'name.[ext];ver'") (LET* ((CHARS (OR (AND (NULL *UPPER-CASE-FILE-NAMES*) (OR (fetch (UNAME ORIGCHARS) of UNAME) (if DIRPTR then (* ; "Get the exact name out of the directory") (\M44READDIRNAME DIRSTREAM DIRPTR)))) (fetch (UNAME UCASECHARS) of UNAME))) (NAME (CONCAT (QUOTE {) (fetch (UNAME PARTNAME) of UNAME) (QUOTE }) (CONCATCODES CHARS) (COND ((MEMB (CHARCODE %.) CHARS) ";") (T ".;")) (fetch (UNAME VERSION) of UNAME)))) (if *UPPER-CASE-FILE-NAMES* then (MKATOM NAME) else NAME)))
)

(\M44READVERSION
(LAMBDA (DIRSTREAM MAXCHARS) (* bvm%: " 7-Jun-84 11:38") (to MAXCHARS bind (VERSION _ 0) C do (SETQ C (\BIN DIRSTREAM)) (COND ((AND (IGEQ C (CHARCODE 0)) (ILEQ C (CHARCODE 9))) (SETQ VERSION (IPLUS (ITIMES VERSION 10) (IDIFFERENCE C (CHARCODE 0))))) (T (* ;; "A non-numeric after a ! means that it wasn't the version marker.  This is permissible by alto file spec") (RETURN))) finally (RETURN VERSION)))
)

(\OPENDISKDESCRIPTOR
  [LAMBDA (DEV)                                          (* ; "Edited 21-Jan-91 23:43 by jds")

    (* ;; "Opens and returns a stream on the disk descriptor file for DEV")

    [COND
       ((NOT (type? FDEV DEV))
        (SETQ DEV (\GETDEVICEFROMNAME (fetch (DSKOBJ DISKDEVICENAME) of DEV]
    (OR (fetch (M44DEVICE DDVALID) of DEV)
        (PROG ((OLDD (fetch (M44DEVICE DISKDESCRIPTOROFD) of DEV))
               STREAM)
              (COND
                 (OLDD (FORGETPAGES OLDD)))
              [SETQ STREAM (COND
                              ((EQ (fetch (M44DEVICE DSKOBJ) of DEV)
                                   \MAINDISK)
                               (\M44OPENFILEFROMFP DEV "DISKDESCRIPTOR.;1" 'BOTH (
                                                                                 \CREATE.FID.FOR.DD
                                                                                      DEV)))
                              (T (\OPENFILE (CONCAT "{" (fetch (FDEV DEVICENAME) of DEV)
                                                   "}" "DISKDESCRIPTOR.;1")
                                        'BOTH]
              (replace USERVISIBLE of STREAM with NIL)
              (replace (M44DEVICE DISKDESCRIPTOROFD) of DEV with STREAM)
              (replace MAXBUFFERS of STREAM with (ADD1 (fetch EPAGE of STREAM)))
                                                             (* ; 
                 "Prepare to buffer the whole file, so that we don't get in trouble under \NEWPAGE")
              (for I from 0 to (fetch EPAGE of STREAM)
                 do (\MAPPAGE I STREAM))                 (* ; 
                                          "Ought to define a \MAPPAGES to do that more efficiently")
              (replace ENDOFSTREAMOP of STREAM with (FUNCTION NILL))
              (replace (M44DEVICE DDVALID) of DEV with T)))
    (fetch (M44DEVICE DISKDESCRIPTOROFD) of DEV])

(\M44READDIRFID
  [LAMBDA (DIRSTREAM DIRPTR FID)                         (* ; "Edited 21-Jan-91 23:39 by jds")

    (* ;; "Read the 5-word FID from the directory into FID (or create a new one if FID is nil).  Return the new FID.")

    (\SETFILEPTR DIRSTREAM (+ DIRPTR 2))
    (\BINS DIRSTREAM [fetch (FID FIDBLOCK) of (OR FID (SETQ FID (create FID]
           0
           (UNFOLD 5 BYTESPERWORD))
    FID])

(\M44READDIRNAME
(LAMBDA (DIRSTREAM DIRPTR) (* ; "Edited 11-Jan-88 14:39 by bvm") (* ;; "Read the exact file name, sans version number, from directory stream as a list of char codes.") (* ;; "Format of a directory entry is --- Type&WordLength (1 word), FP (5 words), Name as a BcplString") (SETFILEPTR DIRSTREAM (+ DIRPTR 12)) (to (SUB1 (BIN DIRSTREAM)) bind CH until (EQ (SETQ CH (BIN DIRSTREAM)) (CHARCODE !)) collect CH))
)

(\M44SEARCHDIR
  [LAMBDA (STREAM TLIST HMIN)                            (* ; "Edited 21-Jan-91 23:37 by jds")

    (* ;; "TLIST is a list of the form (POS . NAMECHARS), where POS at entry is a fileptr in the directory file at which to start searching and NAMECHARS is like the characters pairs of a uname.  Finds next directory entry for which NAMECHARS is a prefix of the filename.  Returns NIL if no entry found, else the length of the remaining chars in the entry.  Leaves the directory positioned after the char matching the last char of NAMECHARS --- STREAM is the ofd of the directory file --- At exit, TLIST is smashed so that POS is the fileptr just beyond the found entry.  --- if HMIN~=NIL, sets STREAM's DIRHOLEPTR to NIL or the fileptr of the first hole of at least HMIN words.")

    (PROG ((CASEBASE (.DISKCASEARRAY.))
           (NEXT (CAR TLIST))
           (NAMECHARS (CDR TLIST))
           THISNAMELENGTH TARGETLENGTH PTR L TYP ENTRYLENGTH)
          (COND
             (HMIN (replace (M44STREAM DIRHOLEPTR) of STREAM with NIL)))
          (SETQ TARGETLENGTH (LENGTH NAMECHARS))
      NEXT
          (\SETFILEPTR STREAM (SETQ PTR NEXT))
          (COND
             ((\EOFP STREAM)
              (RETURN)))

     (* ;; "Format of a directory entry is --- Type (0 = hole, 1 = file), 6 bits --- Length of entry in words, 10 bits --- FP 5 words --- Name as a BcplString")

          (SETQ TYP (\BIN STREAM))
          (SETQ ENTRYLENGTH (IPLUS (LLSH (LOGAND TYP 3)
                                         8)
                                   (\BIN STREAM)))
          (SETQ NEXT (IPLUS (UNFOLD ENTRYLENGTH BYTESPERWORD)
                            PTR))
          (COND
             ((NEQ (LRSH TYP 2)
                   1)                                        (* ; "Not a file")
              (COND
                 ((AND HMIN (NOT (IGREATERP HMIN ENTRYLENGTH)))
                  (replace (M44STREAM DIRHOLEPTR) of STREAM with PTR)
                  (SETQ HMIN NIL)))
              (GO NEXT)))
          (\SETFILEPTR STREAM (IPLUS PTR 12))
          (COND
             ((ILESSP (SETQ THISNAMELENGTH (\BIN STREAM))
                     TARGETLENGTH)
              (GO NEXT)))
          (SETQ L NAMECHARS)
      READ
          (COND
             ((NULL L)                                       (* ; 
                                      "Exhausted the pattern before finding a mismatch, so take it")
              (RPLACA TLIST NEXT)
              (RETURN (IDIFFERENCE THISNAMELENGTH TARGETLENGTH)))
             ((EQ (\GETBASEBYTE CASEBASE (\BIN STREAM))
                  (CAR L))
              (SETQ L (CDR L))
              (GO READ))
             (T (GO NEXT])

(\M44UNPACKFILENAME
  [LAMBDA (NAME DEV CREATEFLG)                           (* ; "Edited 21-Jan-91 23:47 by jds")

    (* ;; "Unpacks file name into a UNAME whose VERSION is the version indicator (either a positive integer or one of OLD, OLDEST, NEW);  PARTNAME is the name of DEV.  UCASECHARS is a list of uppercase charcodes from the name.  If CREATEFLG is true, also sets ORIGCHARS to be list of original char codes, for sake of setting real file name")

    (PROG ((CASEBASE (.DISKCASEARRAY.))
           (NC 0)
           J C UPC END ORIGEND VERSION RESULT DOTPREV ORIGDOTPREV EXCESS TAIL)
          (COND
             ((OR (NOT NAME)
                  (EQ NAME T)
                  (NOT (OR (LITATOM NAME)
                           (STRINGP NAME)))
                  (NEQ (NTHCHARCODE NAME 1)
                       (CHARCODE {))
                  (NOT (SETQ J (STRPOS "}" NAME 5)))
                  (EQ (NTHCHARCODE NAME (add J 1))
                      (CHARCODE <)))

              (* ;; "Name is not a non-null string/atom, or doesn't have a host on front, or { is mismatched, or there's a directory.  There used to be some junk in here about passing back a different value if the name had a directory than if it was otherwise malformed, but we really have no use for that.")

              (RETURN NIL)))
          [SETQ END (fetch (UNAME UCASECHARHEAD) of (SETQ RESULT (create UNAME
                                                                                PARTNAME _
                                                                                (fetch DEVICENAME
                                                                                   of DEV]
                                                             (* ; 
                                                        "End is the cell whose CDR can be smashed.")
          (SETQ ORIGEND (fetch (UNAME ORIGCHARHEAD) of RESULT))
      COLLECTNAME
          (COND
             ((NOT (SETQ C (NTHCHARCODE NAME J)))            (* ; "End of name")
              (GO RET))
             ((EQ (SETQ UPC (\GETBASEBYTE CASEBASE C))
                  0)                                         (* ; "Illegal char")
              (GO ERR))
             (T [RPLACD END (SETQ END (LIST (SELCHARQ UPC
                                                 (; (GO SEMI))
                                                 ((%# *)     (* ; "Wildcards not allowed")
                                                      (GO ERR))
                                                 (%.         (* ; "Omit trailing dots")
                                                     (PROG1 (SELCHARQ (NTHCHARCODE NAME (ADD1 J))
                                                                 (NIL (GO RET))
                                                                 ((; !) 
                                                                      (add J 1)
                                                                      (GO SEMI))
                                                                 UPC)
                                                         (SETQ DOTPREV END)
                                                             (* ; 
                                                   "Save tail position here in case name gets long")
                                                         (AND CREATEFLG (SETQ ORIGDOTPREV ORIGEND))))
                                                 UPC]
                [COND
                   (CREATEFLG                                (* ; "Save orig chars as well")
                          (RPLACD ORIGEND (SETQ ORIGEND (LIST C]
                (add J 1)
                (add NC 1)
                (GO COLLECTNAME)))
      SEMI
          

     (* ;; "Parsing the stuff after the semicolon;  we only accept version, though we do accept the funny symbolic versions H, L and N.")

          (COND
             ([NULL (SETQ C (NTHCHARCODE NAME (add J 1]
              (GO RET))
             ((EQ (SETQ C (\GETBASEBYTE CASEBASE C))
                  0)                                         (* ; "Illegal char")
              (GO ERR)))
          (SELCHARQ C
               (H (SETQQ VERSION OLD))
               (L (SETQQ VERSION OLDEST))
               (N (SETQQ VERSION NEW))
               (GO COLLECTVERSION))
          (if (EQ J (NCHARS NAME))
              then                                       (* ; "Done")
                    (GO RET)
            else                                         (* ; "Malformed name")
                  (GO ERR))
      COLLECTVERSION
          (SETQ VERSION 0)
          [while (AND C (BETWEEN C (CHARCODE 0)
                                   (CHARCODE 9))) do [SETQ VERSION (+ (TIMES VERSION 10)
                                                                          (- C (CHARCODE 0]
                                                        (SETQ C (NTHCHARCODE NAME (add J 1]
          (COND
             ((EQ VERSION 0)
              (SETQQ VERSION OLD))
             ((IGREATERP VERSION 65535)
              (GO ERR)))
          (if (NULL C)
              then                                       (* ; "end of name ok")
                    (GO RET))
      ERR                                                    (* ; "BAD FILE NAME")
          (RETURN NIL)
      RET (replace (UNAME VERSION) of RESULT with VERSION)
          [if (> (SETQ EXCESS (- NC (- \MAX.ALTO.NAME.LENGTH 7)))
                     0)
              then

              (* ;; "Hmm, is name too long?  7 counts for a possible !, 5 version chars and the final dot.  This is unnecessarily restrictive for names with shorter versions, but it would get quite untidy if you let version 9 squeak in and then complain or shorten on 10.  So best to shorten now.  We prefer to leave the extension intact, since that can convey info, and shorten the name.")

              [if DOTPREV
                  then (SETQ DOTPREV (CDR DOTPREV))      (* ; "Now (CAR DOTPREV) is the period")
                        (SETQ ORIGDOTPREV (CDR ORIGDOTPREV))
                        (if (CDR (SETQ TAIL (CL:NTHCDR 10 DOTPREV)))
                            then                         (* ; 
             "Extension longer than 10 chars (this allows, e.g., INTERPRESS), so let's shorten it.")
                                  (if (<= (SETQ NC (LENGTH (CDR TAIL)))
                                              EXCESS)
                                      then               (* ; "Chop off the entire excess")
                                            (RPLACD TAIL NIL)
                                            (if CREATEFLG
                                                then (RPLACD (CL:NTHCDR 10 ORIGDOTPREV)
                                                                NIL))
                                            (SETQ EXCESS (- EXCESS NC))
                                    else                 (* ; "only have to get rid of some")
                                          (RPLACD (CL:NTHCDR (- NC EXCESS)
                                                         TAIL)
                                                 NIL)
                                          (if CREATEFLG
                                              then (RPLACD (CL:NTHCDR (+ 10 (- NC EXCESS))
                                                                      ORIGDOTPREV)
                                                              NIL))
                                          (SETQ EXCESS 0]
              (if (> EXCESS 0)
                  then                                   (* ; "Chop away at name")
                        (RPLACD (NLEFT (fetch (UNAME UCASECHARS) of RESULT)
                                       (ADD1 EXCESS)
                                       DOTPREV)
                               DOTPREV)
                        (if CREATEFLG
                            then (RPLACD (NLEFT (fetch (UNAME ORIGCHARS) of RESULT)
                                                    (ADD1 EXCESS)
                                                    ORIGDOTPREV)
                                            ORIGDOTPREV]
          (RETURN RESULT])
)

(RPAQQ \FILENAMECHARSLST (36 43 45 46))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \FILENAMECHARSLST)
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD UNAME (VERSION . UCASECHARHEAD)
                  (RECORD UCASECHARHEAD (ORIGCHARHEAD . UCASECHARS)
                         (RECORD ORIGCHARHEAD (PARTNAME . ORIGCHARS))))

(RECORD FILESPEC (UNAME FSDIRPTR)
                     [ACCESSFNS FILESPEC ((PNAME (\M44PACKFILENAME (fetch UNAME of DATUM])

(RECORD M44GENFILESTATE (DIROFD SEARCHSTATE GENFILTER GENVERSION HOSTNAME GENSTREAM ENTRYSTART))

(RECORD M44DIRSEARCHSTATE (DIRPTR . CHARLIST))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS BETWEEN MACRO (OPENLAMBDA (V LO HI)
                                       (AND (IGEQ V LO)
                                            (ILEQ V HI))))
)
)
(DEFINEQ

(\CREATE.FID.FOR.DD
  [LAMBDA (FDEV)                                         (* ; "Edited 21-Jan-91 23:39 by jds")

    (* ;; "Creates a FID for the file DISKDESCRIPTOR on FDEV, which must be the default disk partition's device")

    (PROG ((FID (create FID)))

     (* ;; "Currently \SYSDISK has a copy of the diskdescriptor fp inside it, as looked up by alto at beginning of world, so be lazy and use that")

          (\BLT (fetch (FID FIDBLOCK) of FID)
                (LOCF (fetch (M44DEVICE DSKDDBLK) of FDEV))
                \LENFP)
          (RETURN FID])

(\OPENDISK
  [LAMBDA (PARTNUM FDEV)                                 (* ; "Edited 21-Jan-91 23:32 by jds")
    (PROG (DSK DD)
          (OR (\TESTPARTITION PARTNUM)
              (RETURN))
          (SETQ DSK (create DSKOBJ))
          (\LOCKWORDS DSK \NWORDS.DSKOBJ)
          (replace (DSKOBJ DSKPARTITION) of DSK with PARTNUM)
          (replace (DSKOBJ ddPOINTER) of DSK with (LOCF (fetch (DSKOBJ ddLASTSERIAL#)
                                                                       of DSK)))
          (replace (DSKOBJ NDISKS) of DSK with 2)
          (replace (DSKOBJ NTRACKS) of DSK with 406)
          (replace (DSKOBJ NHEADS) of DSK with 2)
          (replace (DSKOBJ NSECTORS) of DSK with 14)
          (replace (DSKOBJ RETRYCOUNT) of DSK with 8)
          (replace (DSKOBJ CBQUEUE) of DSK with (fetch (DSKOBJ CBQUEUE) of 
                                                                                            \MAINDISK
                                                                   ))
                                                             (* ; "Really should have our own")
          (RETURN (\OPENDISKDEVICE PARTNUM DSK FDEV])

(\OPENDISKDEVICE
  [LAMBDA (PARTITION DSKOBJ FDEV)                        (* ; "Edited 21-Jan-91 23:43 by jds")
    (DECLARE (GLOBALVARS \MAINDISK))                     (* ; 
                                            "Creates the model 44 DSK device and opens its SYSDIR.")
    (PROG ([NAME (PACK* 'DSK (OR PARTITION (DISKPARTITION]
           FDEV)
          [OR FDEV (SETQ FDEV (\MAKE.PMAP.DEVICE (create FDEV
                                                        DEVICENAME _ NAME
                                                        NODIRECTORIES _ T
                                                        CLOSEFILE _ (FUNCTION \M44CloseFile)
                                                        DELETEFILE _ (FUNCTION \M44DeleteFile)
                                                        GETFILEINFO _ (FUNCTION \M44GetFileInfo)
                                                        GETFILENAME _ (FUNCTION \M44GetFileName)
                                                        OPENFILE _ (FUNCTION \M44OpenFile)
                                                        READPAGES _ (FUNCTION \M44ReadPages)
                                                        SETFILEINFO _ (FUNCTION \M44SetFileInfo)
                                                        TRUNCATEFILE _ (FUNCTION \M44TruncateFile)
                                                        WRITEPAGES _ (FUNCTION \M44WritePages)
                                                        REOPENFILE _ (FUNCTION \M44OpenFile)
                                                        GENERATEFILES _ (FUNCTION \M44GENERATEFILES)
                                                        EVENTFN _ (FUNCTION \M44EVENTFN)
                                                        DIRECTORYNAMEP _ [FUNCTION (LAMBDA (NAME)
                                                             (* ; 
                                                       "Assume host is OK, check that no directory")
                                                                                     (EQ (NTHCHARCODE
                                                                                          NAME -1)
                                                                                         (CHARCODE
                                                                                          }]
                                                        HOSTNAMEP _ (FUNCTION NILL)
                                                        FREEPAGECOUNT _ (FUNCTION \M44FREEPAGECOUNT)
                                                        OPENP _ (FUNCTION \GENERIC.OPENP)
                                                        REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM)
                                                        UNREGISTERFILE _ (FUNCTION 
                                                                          \GENERIC-UNREGISTER-STREAM]
          (replace (M44DEVICE DSKOBJ) of FDEV with (OR DSKOBJ (SETQ DSKOBJ \MAINDISK)))
          (replace (DSKOBJ DISKDEVICENAME) of DSKOBJ with NAME)
          (RETURN (RESETLST
                      (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (DEV)
                                                       (COND
                                                          ((NOT (fetch (M44DEVICE DSKPASSWORDOK)
                                                                   of DEV))
                                                             (* ; 
                                                           "Oops, it didn't work, take it away")
                                                           (\REMOVEDEVICE DEV]
                                           FDEV))
                      (\DEFINEDEVICE NAME FDEV)              (* ; 
                        "have to define it tentatively first so that \OPENDISKDESCRIPTOR will work")
                      (COND
                         ((\OPENDIR FDEV)
                          (COND
                             ((NULL PARTITION)               (* ; "this is also the default disk")
                              (\DEFINEDEVICE 'DSK FDEV)))
                          FDEV)))])

(\OPENDIR
(LAMBDA (FDEV) (* bvm%: " 6-APR-83 12:16") (* ;; "Opens the model44 directory on the current partition") (PROG ((PART (fetch (M44DEVICE DSKPARTITION) of FDEV)) STREAM DD) (replace (M44DEVICE DSKPASSWORDOK) of FDEV with NIL) (COND ((AND (NEQ PART 0) (NOT (\TESTPARTITION PART))) (replace (M44DEVICE SYSDIROFD) of FDEV with NIL) (RETURN))) (SETQ STREAM (\M44OPENFILEFROMFP FDEV "SYSDIR.;1" (QUOTE BOTH) (create FID W0 _ 32768 W1 _ 100 W2 _ 1 W3 _ 0 W4 _ 1))) (* ; "{DSK}SYSDIR.;1 always has sn 100, leader page on virtual page 1") (replace MAXBUFFERS of STREAM with (IMAX 64 (ADD1 (fetch EPAGE of STREAM)))) (* ; "Enough buffers so that directory is effectively always in core") (replace (M44DEVICE SYSDIROFD) of FDEV with STREAM) (COND ((NEQ PART 0) (SETQ DD (\OPENDISKDESCRIPTOR FDEV)) (\SETFILEPTR DD \OFFSET.DISKLASTSERIAL#) (\BINS DD (LOCF (fetch (M44DEVICE DISKLASTSERIAL#) of FDEV)) 0 \NBYTES.DISKINFO) (add (fetch (M44DEVICE DISKLASTSERIAL#) of FDEV) 3) (* ; "Try to avoid collisions") (COND ((NOT (\M44CHECKPASSWORD FDEV)) (replace (M44DEVICE SYSDIROFD) of FDEV with NIL) (RETURN))))) (replace (M44DEVICE DSKPASSWORDOK) of FDEV with T) (RETURN STREAM)))
)

(\M44CHECKPASSWORD
(LAMBDA (DEV) (* bvm%: "11-Jun-86 12:20") (PROG ((STREAM (\OPENFILE (PACK* (QUOTE {) (fetch (FDEV DEVICENAME) of DEV) "}SYS.BOOT;1") (QUOTE INPUT) (QUOTE OLD))) PASSVECTOR BUF PASSINFO ASKEDONCE NAME N) (COND ((NULL STREAM) (RETURN T))) (SETQ PASSVECTOR (\ALLOCBLOCK (FOLDHI \NWORDS.BCPLPASSWORD WORDSPERCELL))) (SETFILEPTR STREAM \OFFSET.BCPLPASSWORD) (\BINS STREAM PASSVECTOR 0 (UNFOLD \NWORDS.BCPLPASSWORD BYTESPERWORD)) (COND ((EQ (\GETBASE PASSVECTOR 0) 0) (* ; "No password") (\CLOSEFILE STREAM) (RETURN T))) (SETFILEPTR STREAM \OFFSET.BCPLUSERNAME) (SETQ NAME (ALLOCSTRING (SETQ N (\BIN STREAM)))) (* ; "Read in a bcpl string which is the username installed on the disk") (\BINS STREAM (fetch (STRINGP BASE) of NAME) 0 N) (\CLOSEFILE STREAM) (SETQ NAME (MKATOM NAME)) LP (SETQ PASSINFO (\INTERNAL/GETPASSWORD (fetch (FDEV DEVICENAME) of DEV) ASKEDONCE NIL NIL NAME)) (COND ((NULL PASSINFO) (RETURN NIL))) (COND ((UNINTERRUPTABLY (SETQ BUF (\GETPACKETBUFFER)) (* ; "HORRIBLE CHEAP TRICK to get some emulator space") (\BLT (\ADDBASE BUF 64) PASSVECTOR \NWORDS.BCPLPASSWORD) (SetBcplString (\ADDBASE BUF (IPLUS 64 \NWORDS.BCPLPASSWORD)) (\DECRYPT.PWD (CDR PASSINFO))) (\CHECKBCPLPASSWORD (\ADDBASE BUF (IPLUS 64 \NWORDS.BCPLPASSWORD)) (\ADDBASE BUF 64))) (RETURN T)) (T (SETQ ASKEDONCE T) (GO LP)))))
)

(\M44HOSTNAMEP
(LAMBDA (NAME DEV) (* bvm%: "20-Nov-84 16:06") (PROG (PARTNUM) (RETURN (COND ((EQ NAME (QUOTE DSK)) (\OPENDISKDEVICE)) ((AND (STRPOS (QUOTE DSK) NAME 1 NIL T) (SETQ PARTNUM (FIXP (SUBATOM NAME 4))) (\TESTPARTITION PARTNUM)) (COND ((EQ PARTNUM (DISKPARTITION)) (RETURN (\GETDEVICEFROMNAME (QUOTE DSK)))) (T (\OPENDISK PARTNUM))))))))
)
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ \OFFSET.BCPLUSERNAME 512)

(RPAQQ \OFFSET.BCPLPASSWORD 768)

(RPAQQ \NWORDS.BCPLPASSWORD 9)


(CONSTANTS \OFFSET.BCPLUSERNAME \OFFSET.BCPLPASSWORD \NWORDS.BCPLPASSWORD)
)
)



(* ;; "SYSOUT etc.")

(DEFINEQ

(\COPYSYS
(LAMBDA (FILE SYSNAME DONTSAVE) (DECLARE (GLOBALVARS SYSOUTCURSOR \VMEM.INHIBIT.WRITE IDLE.PROFILE)) (* ; "Edited  1-Apr-90 16:27 by nm") (PROG (FULLNAME VAL HOST) RETRY (RECLAIM) (RETURN (COND ((NULL (SETQ VAL (OR (COND ((NOT DONTSAVE) (* ; "Make vmem consistent on disk (like SAVEVM)") (COND (\VMEM.INHIBIT.WRITE (* ; "Force this to NIL, in case someone accidentally got it set to T") (PROMPTPRINT "***WARNING: VMEM.INHIBIT.WRITE was true; setting it to NIL now.") (SETQ \VMEM.INHIBIT.WRITE NIL))) (SETQ FILE (\ADD.CONNECTED.DIR FILE)) (SELECTQ (MACHINETYPE) (MAIKO (SELECTQ (SETQ HOST (U-CASE (FILENAMEFIELD FILE (QUOTE HOST)))) (DSK (* ; "OPENSTREAM with file attributes is not available on DSK and UNIX, so check is done by \DOFLUSHVM ") (* ;; "If  \MAIKO.SYSOUTNAME is non NIL, image is saved by \FLUSHVM, no need to copy") (\FLUSHVM (SETQ FULLNAME (CONCAT "{" HOST "}" (\UFS.RECOGNIZE.FILE FILE (QUOTE NON) (\GETDEVICEFROMNAME HOST)))))) (UNIX (* ; "OPENSTREAM with file attributes is not available on DSK and UNIX, so check is done by \DOFLUSHVM ") (* ;; "If  \MAIKO.SYSOUTNAME is non NIL, image is saved by \FLUSHVM, no need to copy") (\FLUSHVM (SETQ FULLNAME (CONCAT "{" HOST "}" (\UFS.RECOGNIZE.FILE FILE (QUOTE NON) (\GETDEVICEFROMNAME HOST)))))) (RESETLST (PROG1 (\FLUSHVM) (RESETSAVE (CURSOR (COND ((type? CURSOR SYSOUTCURSOR) SYSOUTCURSOR) (T T)))) (LET ((UNIXVAR (UNIX-GETENV "LDEDESTSYSOUT"))) (* ; "\FLSUVM saves image to  Unix enviroment var  or lisp.virtualmem") (SETQ FULLNAME (COPYFILE (COND (UNIXVAR (CONCAT "{DSK}" UNIXVAR)) (T "{DSK}~/lisp.virtualmem")) FILE (QUOTE ((TYPE BINARY)))))))))) (\FLUSHVM)))) (CL:UNWIND-PROTECT (COND ((EQ \MACHINETYPE \MAIKO) NIL) (T (PROGN (SETQ \VMEM.INHIBIT.WRITE T) (* ; "Prevent dirty pages from being written after the \FLUSHVM") (RESETLST (LET ((LASTPAGE (fetch (IFPAGE NActivePages) of \InterfacePage)) STREAM) (* ; "Note length of sysout now, because NActivePages can grow as we prepare to write the sysout") (SETQ STREAM (OPENSTREAM FILE (QUOTE OUTPUT) (QUOTE NEW) NIL (BQUOTE ((LENGTH (\, (UNFOLD LASTPAGE BYTESPERPAGE))) (SEQUENTIAL T) (TYPE BINARY))))) (SETQ FULLNAME (fetch (STREAM FULLNAME) of STREAM)) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (FILE) (CLOSEF FILE) (AND RESETSTATE (DELFILE (fetch (STREAM FULLNAME) of FILE))))) STREAM)) (COND (SYSNAME (SET SYSNAME FULLNAME))) (RESETSAVE (CURSOR (COND ((type? CURSOR SYSOUTCURSOR) (* ; "Comes from a later file") SYSOUTCURSOR) (T T)))) (RESETSAVE IDLE.PROFILE NIL) (* ; "Disable idler") (\COPYSYS1 STREAM LASTPAGE)))))) (* ;; "For cleanup, set \vmem.inhibit.write back to NIL.  This is done as its own cleanup so that impatiently aborting a sysout with repeated ^E will be less likely to miss this restoration.") (SETQ \VMEM.INHIBIT.WRITE NIL))))) (* ;; "First clause of OR is T when resuming this vmem;  second is starting the sysout.  Unless \COPYSYS1 itself does a \FLUSHVM, the second never returns T, yes?  NIL is normal return (continuing in same image), <fixp> is error return") (* ; "Continuing in the current image") (\DAYTIME0 \LASTUSERACTION) FULLNAME) ((AND (SMALLP VAL) (IGREATERP 0 VAL)) (* ; "Error occurred while making sysout.") (LISPERROR (IMINUS VAL) FULLNAME) (GO RETRY)) (T (* ; "Starting sysout") (\CLEARSYSBUF T) (* ; "Get rid of any spurious typeahead") (\RESETKEYBOARD) (* ; "Enable keyhandler") (LIST FULLNAME))))))
)

(\COPYSYS1
(LAMBDA (STREAM LASTPAGE) (* ; "Edited 21-Aug-88 13:54 by bvm") (COND ((AND (type? M44DEVICE (fetch DEVICE of STREAM)) (EQ (fetch DEVICENAME of (fetch DEVICE of STREAM)) (QUOTE DSK))) (ERROR "Sysout to Dorado login partition no longer supported."))) (PROG ((ACTONVMEMFN \VMEMACCESSFN) (PAGEMAPPED (fetch PAGEMAPPED of (fetch DEVICE of STREAM))) (NBUFS (SUB1 \#EMUBUFFERS)) (BUFBASE \EMUBUFFERS) (FIRSTPAGE 2) (CURSORBAR \EM.CURSORBITMAP) (CURSORMASK (LLSH 1 (SUB1 BITSPERWORD))) (DOMINOPAGE (fetch LastDominoFilePage of \InterfacePage)) (DAYBREAKP (EQ \MACHINETYPE \DAYBREAK)) CURSORINC CURSORNEXT NPAGES BUFFERS) (* ;; "Strategy is to copy from the vmem file to STREAM --- The vmem file is read with \ACTONVMEMFILE to finesse the differences among machines.  As buffers we use the set of pre-allocated swap buffers, reducing the number available for swapping to a bare minimum of one.  If STREAM is pagemapped, we take advantage of knowledge of pagemapped streams to write these buffers directly to the destination stream, which saves the copying that would occur if we just generically used \BOUTS for all streams.  In the case of Mod44 DSK, this also lets us use more buffers at a time, because DSK can write directly from the buffers we use for reading the vmem, rather than copying into its own buffers") (RESETSAVE \#SWAPBUFFERS 1) (* ; "Reduce us to one swap buffer, so we can use the rest for copying the vmem") (RESETSAVE \EMUSWAPBUFFERS (\ADDBASE BUFBASE (UNFOLD NBUFS WORDSPERPAGE))) (RESETSAVE \#DISKBUFFERS (COND ((type? M44DEVICE (fetch DEVICE of STREAM)) (* ; "DSK code needs 1 extra buffer beyond the ones we give to \WRITEPAGES") (SETQ NBUFS (SUB1 NBUFS)) (SETQ BUFBASE (\ADDBASE BUFBASE WORDSPERPAGE)) 1) (T 0))) (SETQ BUFFERS (to NBUFS as (BUF _ BUFBASE) by (\ADDBASE BUF WORDSPERPAGE) collect BUF)) (SETQ CURSORINC (SETQ CURSORNEXT (FOLDLO LASTPAGE (ITIMES 16 16)))) (* ; "How often to do something to the cursor") (COND ((EQ DOMINOPAGE 0) (* ; "First page to write is the ISF map page, which should be blank in a sysout") (\CLEARWORDS BUFBASE WORDSPERPAGE)) (T (CL:FUNCALL ACTONVMEMFN DOMINOPAGE BUFBASE 1))) (COND (PAGEMAPPED (replace EPAGE of STREAM with LASTPAGE) (* ; "Set up end of file correctly.  LASTPAGE is last alto page (full), which is last Lisp page plus 1") (replace EOFFSET of STREAM with 0) (\WRITEPAGES STREAM 0 (CAR BUFFERS))) (T (\BOUTS STREAM (CAR BUFFERS) 0 BYTESPERPAGE))) (while (<= FIRSTPAGE LASTPAGE) do (COND ((>= FIRSTPAGE CURSORNEXT) (* ; "Gradually complement the cursor") (\PUTBASE CURSORBAR 0 (LOGXOR (\GETBASE CURSORBAR 0) CURSORMASK)) (COND (DAYBREAKP (\DoveDisplay.SetCursorShape))) (add CURSORNEXT CURSORINC) (COND ((EQ (SETQ CURSORMASK (LRSH CURSORMASK 1)) 0) (SETQ CURSORBAR (\ADDBASE CURSORBAR 1)) (SETQ CURSORMASK (LLSH 1 (SUB1 BITSPERWORD))))))) (CL:FUNCALL ACTONVMEMFN FIRSTPAGE BUFBASE (SETQ NPAGES (IMIN NBUFS (ADD1 (- LASTPAGE FIRSTPAGE))))) (* ; "Read NBUFS pages from vmem, then write them to output") (COND ((NOT PAGEMAPPED) (* ; "Have to just ship the bits") (\BOUTS STREAM BUFBASE 0 (UNFOLD NPAGES BYTESPERPAGE))) (T (\WRITEPAGES STREAM (SUB1 FIRSTPAGE) (COND ((< NPAGES NBUFS) BUFFERS) (T (* ; "Don't write too many pages on the last pass if NPAGES is less than length of BUFFERS") (to NPAGES as BUF in BUFFERS collect BUF)))))) (add FIRSTPAGE NPAGES)) (RETURN NIL)))
)
)



(* ;; "For MAIKO. \COPYSYS use UNIX-PAGEPERBLOCK.")

(DEFINEQ

(\MAIKO.CHECKFREESPACE
(LAMBDA (FILENAME) (* ; "Edited  1-Apr-90 18:24 by nm") (DECLARE (GLOBALVARS \LDEDESTOVERWRITE \DSKdevice)) (LET ((LASTPAGE (fetch (IFPAGE NActivePages) of \InterfacePage)) (BUFFER (CREATECELL \FIXP)) FULLNAME FILESIZE FREEPAGES HOST) (* ;; "FULLNAME is  UNIX/DSK format pathname with UNIX/DSK. And type is string.") (SETQ FULLNAME (if (NULL FILENAME) then (SETQ HOST (QUOTE DSK)) (\UFS.RECOGNIZE.FILE (CONCAT "{" HOST "}" (OR (UNIX-GETENV "LDEDESTSYSOUT") "~/lisp.virtualmem")) (QUOTE NON) (\GETDEVICEFROMNAME HOST)) else (SETQ HOST (U-CASE (FILENAMEFIELD FILENAME (QUOTE HOST)))) (\UFS.RECOGNIZE.FILE FILENAME (QUOTE NON) (\GETDEVICEFROMNAME HOST)))) (SETQ FULLNAME (CONCAT "{" HOST "}" FULLNAME)) (* ;; "get current free space") (OR (\UFSGetFreeBlock-C FULLNAME BUFFER) (LISPERROR "FILE NOT FOUND" FULLNAME)) (if (IGREATERP LASTPAGE (SETQ FREEPAGES (ITIMES BUFFER LISPPAGE-PER-UNIXBLOCK))) then (* ;; "not enough free space ") (if \LDEDESTOVERWRITE then (* ;; "if possible, try to overwrite") (OR (INFILEP FULLNAME) (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME FULLNAME)) (* ;; "file exist, check file size") (SETQ FILESIZE (GETFILEINFO FULLNAME (QUOTE SIZE))) (if (IGREATERP LASTPAGE (IPLUS FILESIZE FREEPAGES)) then (* ;; "also, not ehough space") (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME FULLNAME) else (* ;; "Remove file, then get enoght space to save") (DELFILE FULLNAME)) else (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME FULLNAME)))))
)
)

(RPAQ? \LDEDESTOVERWRITE NIL)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ LISPPAGE-PER-UNIXBLOCK 2)


(CONSTANTS (LISPPAGE-PER-UNIXBLOCK 2))
)
)



(* ;; 
"Stats code.  On MOD44IO because it writes on the disk and uses records not exported from MOD44IO.  (For this and other reasons, GATHERSTATS only works on Dorados.)"
)

(DEFINEQ

(GATHERSTATS
  [LAMBDA (FILENAME)                                     (* ; "Edited 21-Jan-91 23:33 by jds")

    (* ;; "Enables and disables statistics gathering.  Uses low level file operations to avoid stats file being visible from Lisp b/c the file position is not updated as it is written")

    (DECLARE (GLOBALVARS \STATSON))
    (COND
       ((NEQ \MACHINETYPE \DORADO)
        (ERROR "Stats not implemented for this type of machine" FILENAME))
       [FILENAME (AND \STATSON (GATHERSTATS))
              (SELECTQ (FILENAMEFIELD FILENAME 'HOST)
                  (DSK)
                  (NIL (SETQ FILENAME (PACKFILENAME.STRING 'HOST 'DSK 'BODY FILENAME)))
                  (ERROR "Stats file must be on DSK" FILENAME))
              (SETQ \STATSON T)
              (\GATHERSTATS (PROG [(STREAM (\OPENFILE FILENAME 'OUTPUT 'NEW]
                                                             (* ; 
                "CLose before doing stats, cause file isn't really open from Lisp's point of view.")
                                  (RETURN (fetch (ARRAYP BASE)
                                             of (fetch (M44STREAM FID)
                                                       of (PROG1 STREAM
                                                                  (\CLOSEFILE STREAM)
                                                                  (\M44FLUSHDISKDESCRIPTOR
                                                                   (fetch DEVICE of STREAM))
                                                                  (replace (DSKOBJ DDVALID)
                                                                     of (fetch DEVICE
                                                                               of STREAM)
                                                                     with NIL))]
       (\STATSON (\GATHERSTATS)
              (SETQ \STATSON NIL])
)

(RPAQQ \STATSON NIL)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)


(FILESLOAD (LOADCOMP)
       LLBFS)
)
(PUTPROPS MOD44IO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (5090 66819 (\M44AddDiskPages 5100 . 6368) (\M44CloseFile 6370 . 6677) (\M44CompleteFH 
6679 . 11093) (\M44CREATEFILE 11095 . 17025) (\M44DeleteFile 17027 . 18116) (\M44EVENTFN 18118 . 22495
) (\M44ExtendFilePageMap 22497 . 24548) (\M44FillInMap 24550 . 26900) (\M44GetFileHandle 26902 . 29006
) (\M44GetFileInfo 29008 . 33191) (\M44GETDATEPROP 33193 . 33675) (\M44GetFileName 33677 . 34114) (
\M44GetPageLoc 34116 . 34917) (\M44KillFilePageMap 34919 . 35290) (\M44MAKEDIRENTRY 35292 . 37023) (
\M44OpenFile 37025 . 43158) (\M44OPENFILEFROMFP 43160 . 44188) (\M44ReadDiskPage 44190 . 46417) (
\M44ReadLeaderPage 46419 . 47871) (\M44ReadPages 47873 . 48090) (\M44SetAccessTimes 48092 . 49377) (
\M44SetEndOfFile 49379 . 50870) (\M44SetFileInfo 50872 . 52126) (\M44SETFILETYPE 52128 . 54741) (
\M44TruncateFile 54743 . 56196) (\M44WriteDiskPage 56198 . 60420) (\M44WriteLeaderPage 60422 . 61280) 
(\M44WritePages 61282 . 63666) (\M44WritePages1 63668 . 66817)) (66853 79777 (\ADDDISKPAGES 66863 . 
68676) (\M44DELETEPAGES 68678 . 72720) (\ASSIGNDISKPAGE 72722 . 75974) (\COUNTDISKFREEPAGES 75976 . 
76513) (\M44MARKPAGEFREE 76515 . 77215) (\M44FLUSHDISKDESCRIPTOR 77217 . 78159) (\MAKELEADERDAS 78161
 . 78872) (DISKFREEPAGES 78874 . 79220) (\M44FREEPAGECOUNT 79222 . 79670) (VMEMSIZE 79672 . 79775)) (
82930 97231 (\M44GENERATEFILES 82940 . 85860) (\M44SORTFILES 85862 . 86239) (\M44GENERATENEXT 86241 . 
91886) (\M44NEXTFILEFN 91888 . 93151) (\M44SORTEDNEXTFILEFN 93153 . 95276) (\M44FILEINFOFN 95278 . 
97229)) (97275 122542 (\M44PARSEFILENAME 97285 . 105317) (\FINDDIRHOLE 105319 . 107302) (
\M44PACKFILENAME 107304 . 107934) (\M44READVERSION 107936 . 108362) (\OPENDISKDESCRIPTOR 108364 . 
110471) (\M44READDIRFID 110473 . 110909) (\M44READDIRNAME 110911 . 111341) (\M44SEARCHDIR 111343 . 
114084) (\M44UNPACKFILENAME 114086 . 122540)) (123381 132404 (\CREATE.FID.FOR.DD 123391 . 123996) (
\OPENDISK 123998 . 125287) (\OPENDISKDEVICE 125289 . 129538) (\OPENDIR 129540 . 130716) (
\M44CHECKPASSWORD 130718 . 132047) (\M44HOSTNAMEP 132049 . 132402)) (132673 139416 (\COPYSYS 132683 . 
136057) (\COPYSYS1 136059 . 139414)) (139477 140993 (\MAIKO.CHECKFREESPACE 139487 . 140991)) (141341 
143329 (GATHERSTATS 141351 . 143327)))))
STOP
\ No newline at end of file
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "16-Mar-2021 19:55:51" {DSK}<home>larry>ilisp>medley>sources>MOD44IO.;3 139027 

      changes to%:  (VARS MOD44IOCOMS)

      previous date%: "16-Mar-2021 10:09:07" {DSK}<home>larry>ilisp>medley>sources>MOD44IO.;2)


(* ; "
Copyright (c) 1981-1991, 2021 by Venue & Xerox Corporation.
")

(PRETTYCOMPRINT MOD44IOCOMS)

(RPAQQ MOD44IOCOMS
       (

(* ;;; "Dorado disk driver")

        (COMS 
              (* ;; "Device dependent code for the Model44 disk")

              (FNS \M44AddDiskPages \M44CloseFile \M44CompleteFH \M44CREATEFILE \M44DeleteFile 
                   \M44EVENTFN \M44ExtendFilePageMap \M44FillInMap \M44GetFileHandle \M44GetFileInfo
                   \M44GETDATEPROP \M44GetFileName \M44GetPageLoc \M44KillFilePageMap 
                   \M44MAKEDIRENTRY \M44OpenFile \M44OPENFILEFROMFP \M44ReadDiskPage 
                   \M44ReadLeaderPage \M44ReadPages \M44SetAccessTimes \M44SetEndOfFile 
                   \M44SetFileInfo \M44SETFILETYPE \M44TruncateFile \M44WriteDiskPage 
                   \M44WriteLeaderPage \M44WritePages \M44WritePages1))
        (COMS 
              (* ;; "Disk allocation")

              (FNS \ADDDISKPAGES \M44DELETEPAGES \ASSIGNDISKPAGE \COUNTDISKFREEPAGES \M44MARKPAGEFREE
                   \M44FLUSHDISKDESCRIPTOR \MAKELEADERDAS DISKFREEPAGES \M44FREEPAGECOUNT))
        (COMS (INITVARS (\M44MULTFLG T))
              (DECLARE%: DONTCOPY (MACROS UCASECHAR UPDATEVALIDATION)
                     (RECORDS M44DEVICE)
                     (GLOBALVARS \OPENFILES \M44MULTFLG \DISKNAMECASEARRAY)
                     (MACROS .LISP.TO.BFS. .BFS.TO.LISP. .DISKCASEARRAY.)
                     (CONSTANTS (PageMapIncrement 64)
                            (\MAX.ALTO.NAME.LENGTH 39))
                     (COMS 
                           (* ;; "File properties")

                           (RECORDS M44FILEPROP)
                           (CONSTANTS * FPROPTYPES)
                           (CONSTANTS * FPTYPES))
                     (GLOBALRESOURCES \M44PAGEBUFFER))
              (INITRESOURCES \M44PAGEBUFFER))
        (COMS 
              (* ;; "Directory enumeration")

              (FNS \M44GENERATEFILES \M44SORTFILES \M44GENERATENEXT \M44NEXTFILEFN 
                   \M44SORTEDNEXTFILEFN \M44FILEINFOFN))
        (COMS 
              (* ;; "Directory lookup routines")

              (FNS \M44PARSEFILENAME \FINDDIRHOLE \M44PACKFILENAME \M44READVERSION 
                   \OPENDISKDESCRIPTOR \M44READDIRFID \M44READDIRNAME \M44SEARCHDIR 
                   \M44UNPACKFILENAME)
              (VARS \FILENAMECHARSLST)
              (GLOBALVARS \FILENAMECHARSLST)
              (DECLARE%: DONTCOPY (RECORDS UNAME FILESPEC M44GENFILESTATE M44DIRSEARCHSTATE)
                     (MACROS BETWEEN)))
        (COMS (FNS \CREATE.FID.FOR.DD \OPENDISK \OPENDISKDEVICE \OPENDIR \M44CHECKPASSWORD 
                   \M44HOSTNAMEP)
              (DECLARE%: DONTCOPY (CONSTANTS \OFFSET.BCPLUSERNAME \OFFSET.BCPLPASSWORD 
                                         \NWORDS.BCPLPASSWORD)))
        [COMS 
              (* ;; "SYSOUT etc.")

              (FNS \COPYSYS1)
              
              (* ;; "For MAIKO. \COPYSYS use UNIX-PAGEPERBLOCK.")

              (FNS \MAIKO.CHECKFREESPACE)
              (INITVARS (\LDEDESTOVERWRITE NIL))
              (DECLARE%: DONTCOPY (CONSTANTS (LISPPAGE-PER-UNIXBLOCK 2]
        (COMS 
              (* ;; "Stats code.  On MOD44IO because it writes on the disk and uses records not exported from MOD44IO.  (For this and other reasons, GATHERSTATS only works on Dorados.)")

              (FNS GATHERSTATS)
              (VARS (\STATSON NIL)))
        (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T)
               (FILES (LOADCOMP)
                      LLBFS))))



(* ;;; "Dorado disk driver")




(* ;; "Device dependent code for the Model44 disk")

(DEFINEQ

(\M44AddDiskPages
  [LAMBDA (STREAM NEWLASTPAGE NEWLASTBYTE)               (* ; "Edited 21-Jan-91 23:35 by jds")

    (* ;; "Add pages to an existing Model44 file.  NEWLASTPAGE is the page number of the last page in the extended file.  Return the disk address of the new last page.")

    (\M44FillInMap STREAM (fetch (M44STREAM LastPage) of STREAM))
                                                             (* ; 
                     "Fill in map to end of file.  Code below assumes at least one valid map entry")
    (\ADDDISKPAGES STREAM (ADD1 (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
           (IDIFFERENCE NEWLASTPAGE (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
           (fetch (ARRAYP BASE) of (\M44ExtendFilePageMap STREAM NEWLASTPAGE))
           NEWLASTBYTE)
    (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with NEWLASTPAGE)
    (replace (M44STREAM LastPage) of STREAM with NEWLASTPAGE)
    (replace (M44STREAM LastOffset) of STREAM with NEWLASTBYTE)
                                                             (* ; 
                                                           "record new eof in filehandle only")
    NEWLASTPAGE])

(\M44CloseFile
(LAMBDA (STREAM) (* hdj "25-Sep-86 11:03") (\CLEARMAP STREAM) (COND ((NEQ (fetch ACCESS of STREAM) (QUOTE INPUT)) (* ; "Update EOF in leader page") (\M44TruncateFile STREAM (fetch EPAGE of STREAM) (fetch EOFFSET of STREAM) T) (\M44FLUSHDISKDESCRIPTOR (fetch DEVICE of STREAM)))) STREAM)
)

(\M44CompleteFH
  [LAMBDA (STREAM)                                       (* ; "Edited 21-Jan-91 23:41 by jds")

    (* ;; "Completes the fields of a file handle that describes an existing file by reading in its leader page which it leaves for its caller")

    (PROG ((NUMCHARS (CONS))
           (LEADERPAGE (\M44ReadLeaderPage STREAM))
           (DSK (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)))
           LASTPAGE# NBYTES)

     (* ;; "Get the page number and the number of bytes on the last page of the file specified by fHandle.  If the last page number hint is wrong in the leader page, then find the real last page and change the hint.")

          (COND
             ((AND (NEQ (SETQ LASTPAGE# (.BFS.TO.LISP. (fetch (\M44LeaderPage LastPageNumber)
                                                          of LEADERPAGE)))
                        -1)
                   (EQ [PROG ((DAs (ARRAY 3 'WORD \FILLINDA 0))
                              (BFSPG# (.LISP.TO.BFS. LASTPAGE#)))
                             (SETA DAs 1 (fetch (\M44LeaderPage LastPageAddress) of 
                                                                                           LEADERPAGE
                                                ))
                             (SETA DAs 2 \EOFDA)
                             (RETURN (AND (EQ (\ACTONDISKPAGES DSK NIL (fetch (ARRAYP BASE)
                                                                          of DAs)
                                                     LASTPAGE# STREAM BFSPG# BFSPG# \DC.READD 
                                                     NUMCHARS NIL T)
                                              BFSPG#)
                                          (SETQ NBYTES (CAR NUMCHARS]
                       (fetch (\M44LeaderPage LastPageByteCount) of LEADERPAGE)))
              (replace (M44STREAM LastPage) of STREAM with LASTPAGE#)
                                                             (* ; "Update STREAM eof")
              (replace (M44STREAM LastOffset) of STREAM with NBYTES))
             (T                                              (* ; 
                                                    "Hint was wrong so scan the file for last page")
                (for PN from PageMapIncrement by PageMapIncrement
                   do (SETQ LASTPAGE# (\M44FillInMap STREAM PN)) 
                                                             (* ; 
                                                           "Wait until attempt to find page fails")
                   repeatwhile (EQ PN LASTPAGE#))
                (SETQ NBYTES (\ACTONDISKPAGES DSK NIL (fetch (ARRAYP BASE)
                                                         of (fetch (M44STREAM FILEPAGEMAP)
                                                                   of STREAM))
                                    -1 STREAM (.LISP.TO.BFS. LASTPAGE#)
                                    (.LISP.TO.BFS. LASTPAGE#)
                                    \DC.READD NUMCHARS))     (* ; 
                                              "Read last page to find out how many bytes are on it")
                (\M44SetEndOfFile STREAM LASTPAGE# (CAR NUMCHARS)
                       T)))
          (UPDATEVALIDATION STREAM LEADERPAGE)               (* ; 
                                         "Validation is low order bits of creation and write dates")
          [COND
             ((EQ (fetch (M44STREAM LastOffset) of STREAM)
                  BYTESPERPAGE)

              (* ;; "Shouldn't happen, because alto files should never have a full last page.  However, cope if it happens...")

              (replace EPAGE of STREAM with (ADD1 (fetch (M44STREAM LastPage)
                                                                 of STREAM)))
              (replace EOFFSET of STREAM with 0))
             (T (replace EPAGE of STREAM with (fetch (M44STREAM LastPage)
                                                             of STREAM))
                (replace EOFFSET of STREAM with (fetch (M44STREAM LastOffset)
                                                               of STREAM]
          (RETURN STREAM])

(\M44CREATEFILE
  [LAMBDA (FDEV UNAME LENGTH CRDATE TYPE DIRECTORYP)     (* ; "Edited 21-Jan-91 23:41 by jds")

    (* ;; "Create a file on the Model44 disk.")

    (PROG ((DSK (fetch (M44DEVICE DSKOBJ) of FDEV))
           (PNAME (\M44PACKFILENAME UNAME))
           (LEADERPAGE (create \M44LeaderPage))
           (NC 0)
           STREAM FP MAP FPBASE DAT PSTART)
          (OR PNAME (RETURN))                                (* ; 
                                                           "Cant create as name wasnt complete")
          (SETQ STREAM (create M44STREAM))
          (replace FULLFILENAME of STREAM with PNAME)
          (replace DEVICE of STREAM with FDEV)
          (replace (M44STREAM FID) of STREAM with (SETQ FP (create FID)))
          (replace (M44STREAM FILEPAGEMAP) of STREAM
             with (SETQ MAP (ARRAY (COND
                                          ((FIXP LENGTH)
                                           (IPLUS 4 (FOLDHI LENGTH BYTESPERPAGE)))
                                          (T PageMapIncrement))
                                       'WORD \FILLINDA 0)))
          (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with 0)
          (replace MULTIBUFFERHINT of STREAM with \M44MULTFLG)
          (replace (M44STREAM LEADERPAGE) of STREAM with LEADERPAGE)
          (SETQ FPBASE (fetch (ARRAYP BASE) of FP))
          (replace (FP FPSERIAL#) of FPBASE with (add (fetch (DSKOBJ 
                                                                                      DISKLASTSERIAL#
                                                                                        )
                                                                         of DSK)
                                                                    1))
          (COND
             (DIRECTORYP (add (fetch (FP FPSERIALHI) of FPBASE)
                                \FP.DIRECTORYP)))
          (replace (FP FPVERSION) of FPBASE with 1)
          (SETA MAP 0 \EOFDA)
          (SETA MAP 3 \EOFDA)                                (* ; 
                             "We are about to create pages 0 and 1, everything else is nonexistent")
                                                             (* ; 
                         "Done by the NCREATE -- (\ZEROPAGE (fetch (POINTER PAGE#) of LEADERPAGE))")
          (\BLT (LOCF (fetch (\M44LeaderPage TimeWrite) of LEADERPAGE))
                (SETQ DAT (\DAYTIME0 (create FIXP)))
                WORDSPERCELL)                                (* ; "Set creation and write dates")
          (\BLT (LOCF (fetch (\M44LeaderPage TimeCreate) of LEADERPAGE))
                (OR CRDATE DAT)
                WORDSPERCELL)                                (* ; 
                                                         "See \M44MAKEDIRENTRY for the name logic.")
          (for C in (fetch (UNAME ORIGCHARS) of UNAME)
             bind (NAMEBASE _ (LOCF (fetch (\M44LeaderPage NameCharCount) of LEADERPAGE))
                             )
                   (V _ (fetch (UNAME VERSION) of UNAME))
             do (\PUTBASEBYTE NAMEBASE (add NC 1)
                           C) finally [COND
                                             ((NEQ V 1)
                                              (\PUTBASEBYTE NAMEBASE (add NC 1)
                                                     (CHARCODE !))
                                              (for C in (CHCON V)
                                                 do (\PUTBASEBYTE NAMEBASE (add NC 1)
                                                               C]
                                    (\PUTBASEBYTE NAMEBASE (add NC 1)
                                           (CHARCODE %.))    (* ; 
                                                          "Last character of all alto names is dot")
                                    (replace (\M44LeaderPage NameCharCount) of LEADERPAGE
                                       with NC))
          (replace (\M44LeaderPage PropertyBegin) of LEADERPAGE
             with (INDEXF (FETCH (\M44LeaderPage LeaderProps) of LEADERPAGE)))
          [replace (\M44LeaderPage PropertyLength) of LEADERPAGE
             with (CONSTANT (- (INDEXF (FETCH (\M44LeaderPage Spares) of LEADERPAGE))
                                   (INDEXF (FETCH (\M44LeaderPage LeaderProps) of LEADERPAGE]
                                                             (* ; "The start and length of the property section are theoretically variable, but at least some %"official%" Alto software, such as Scavenge, believes that file names must be no more than 39 chars.")
          (\M44SETFILETYPE STREAM TYPE)
          (\WRITEDISKPAGES DSK (LIST LEADERPAGE NIL)
                 (fetch (ARRAYP BASE) of MAP)
                 -1 STREAM 0 1 NIL NIL 0 0)                  (* ; 
                    "The end of file will be zero and the validation not set as befits a new file.")
          (replace (FP FPLEADERVDA) of FPBASE with (\WORDELT MAP 1))
                                                             (* ; 
                                     "Now that the file is safely created, make entry in directory")
          (replace (M44STREAM DIRINFO) of STREAM with (\M44MAKEDIRENTRY
                                                                   (fetch (M44STREAM FID)
                                                                      of STREAM)
                                                                   UNAME NC FDEV))
          (RETURN STREAM])

(\M44DeleteFile
  [LAMBDA (FILENAME DEV)                                 (* ; "Edited 21-Jan-91 23:35 by jds")
                                                             (* ; "Delete a Model44 file.")
    (PROG ((STREAM (\M44GetFileHandle FILENAME 'OLDEST DEV T)))
          (COND
             ((OR (NOT STREAM)
                  (FDEVOP 'OPENP DEV (fetch FULLFILENAME of STREAM)
                         NIL DEV))                           (* ; "Can't delete an open file")
              (RETURN)))
          (\M44DELETEPAGES STREAM -1)
          (PROG ((DIROFD (fetch (M44DEVICE SYSDIROFD) of DEV)))
                                                             (* ; "Delete directory entry")
                (\SETFILEPTR DIROFD (fetch (M44STREAM DIRINFO) of STREAM))
                (\BOUT DIROFD (LOGAND 3 (\PEEKBIN DIROFD)))
                (FLUSHMAP DIROFD))
          (\M44KillFilePageMap STREAM)
          (replace (M44STREAM FID) of STREAM with NIL)
          (RETURN (fetch FULLFILENAME of STREAM])

(\M44EVENTFN
  [LAMBDA (FDEV EVENT)                                   (* ; "Edited 21-Jan-91 23:31 by jds")
    (DECLARE (GLOBALVARS \DEVICENAMETODEVICE \MACHINETYPE))
    (SELECTQ EVENT
        ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) 
                                                            (* ;; 
                                          "reinitialize DSK device and revalidate its open streams")

             [PROG ((DSKOBJ (fetch (M44DEVICE DSKOBJ) of FDEV))
                    DD)
                   (COND
                      ((SETQ DD (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSKOBJ))
                                                             (* ; 
                                                           "Flush out of date disk descriptor")
                       (FORGETPAGES DD)
                       (FDEVOP 'UNREGISTERFILE FDEV FDEV DD) (* ; 
      "Stream no longer in use.  Don't go thru \M44CloseFile because it will try to Truncate, etc.")
                       (replace (DSKOBJ DDVALID) of DSKOBJ with NIL)
                       (replace (DSKOBJ DISKDESCRIPTOROFD) of DSKOBJ with NIL)))
                   (FORGETPAGES (fetch (DSKOBJ SYSDIROFD) of DSKOBJ))
                   (FDEVOP 'UNREGISTERFILE FDEV FDEV (fetch (DSKOBJ SYSDIROFD) of DSKOBJ))
                   (COND
                      [(AND (EQ \MACHINETYPE \DORADO)
                            (LET [(PARTZEROP (EQ (fetch (M44DEVICE DSKPARTITION) of FDEV)
                                                 0))
                                  (CURPARTP (EQ (fetch (FDEV DEVICENAME) of FDEV)
                                                (PACK* 'DSK (DISKPARTITION]
                                 (COND
                                    (PARTZEROP               (* ; 
       "This is interlock with \M44EXTENDVMEMFILE which doesn't want to mess up the DiskDescriptor")
                                           (SETQ \M44.READY T)))
                                 (COND
                                    ((OR (AND PARTZEROP CURPARTP)
                                         (\DEVICE-OPEN-STREAMS FDEV))
                                     (COND
                                        ((EQ PARTZEROP CURPARTP)
                                                             (* ; 
                                              "No partition change to worry about, just reopen dir")
                                         (\OPENDIR FDEV))
                                        (PARTZEROP 

                                   (* ;; "This was the default partition, no longer is, so reopen it as if from scratch.  Also, remove the mapping of DSK to this device")

                                               (\REMOVEDEVICE.NAMES FDEV 'DSK)
                                               (\OPENDISK (SUBATOM (fetch (FDEV DEVICENAME)
                                                                          of FDEV)
                                                                     4)
                                                      FDEV))
                                        (T                   (* ; 
       "This was a non-default partition, now the default.  Reopen it with \MAINDISK as its DSKOBJ")
                                           (\OPENDISKDEVICE NIL NIL FDEV]
                      (T 
                         (* ;; "Device no longer exists if machine is now Dandelion;  and if there were no open files, no need to try reopening the dir")

                         (replace (DSKOBJ SYSDIROFD) of DSKOBJ with NIL)

                         (* ;; "Have to explicitly clear these fields, because when we drop the DSKOBJ on the floor, GC does not know about its POINTER fields")

                         (replace REOPENFILE of FDEV with (FUNCTION NILL))
                                                             (* ; 
                            "In case there are files open over sysout as we come back on Dandelion")
                         (\REMOVEDEVICE FDEV]
             (\PAGED.REVALIDATEFILELST FDEV))
        (BEFORELOGOUT (\FLUSH.OPEN.STREAMS FDEV)
                      (\M44FLUSHDISKDESCRIPTOR FDEV))
        NIL])

(\M44ExtendFilePageMap
  [LAMBDA (STREAM TOPAGE#)                               (* ; "Edited 21-Jan-91 23:35 by jds")

    (* ;; "If the file's page map is not big enough to map the given page, then create a new one that is big enough and copy the old OLDMAP information into the new map.  If the file has no map, then create one big enough to map the given page.  Return the new map.  --- Map entry 0 corresponds to bfs page -1, entry 1 corresponds to the leader page, and entry 2 corresponds to Lisp page 0")

    (PROG ((OLDMAP (fetch (M44STREAM FILEPAGEMAP) of STREAM))
           OLDSIZE NEWMAP)
          (RETURN (COND
                     ([AND OLDMAP (ILESSP (IPLUS TOPAGE# 3)
                                         (SETQ OLDSIZE (fetch (ARRAYP LENGTH) of OLDMAP]
                      OLDMAP)
                     (T (SETQ NEWMAP (ARRAY (CEIL (IPLUS TOPAGE# 4)
                                                  PageMapIncrement)
                                            'SMALLPOSP \FILLINDA 0))
                        [COND
                           (OLDMAP                           (* ; "Copy old map into new")
                                  (\BLT (fetch (ARRAYP BASE) of NEWMAP)
                                        (fetch (ARRAYP BASE) of OLDMAP)
                                        OLDSIZE))
                           (T                                (* ; 
                                                           "Initialize with leader page hint")
                              (SETA NEWMAP 0 \EOFDA)
                              (SETA NEWMAP 1 (fetch (FP FPLEADERVDA)
                                                of (fetch (ARRAYP BASE)
                                                          of (fetch (M44STREAM FID)
                                                                    of STREAM]
                        (replace (M44STREAM FILEPAGEMAP) of STREAM with NEWMAP)
                        NEWMAP])

(\M44FillInMap
  [LAMBDA (STREAM UPTOPAGE)                              (* ; "Edited 21-Jan-91 23:42 by jds")

(* ;;; "Assures that the disk address map for STREAM is filled in up thru page# UPTOPAGE.  Reads file as needed")

    (PROG ((MAP (\M44ExtendFilePageMap STREAM UPTOPAGE))
           (DSK (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)))
           (LASTKNOWNPAGE (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
           NPAGES LASTPAGEREAD LASTATTEMPTED DAs DA)         (* ; "Extend MAP")
          (SETQ DAs (fetch (ARRAYP BASE) of MAP))
          [while (ILESSP LASTKNOWNPAGE UPTOPAGE)
             do (COND
                       [(NEQ (SETQ DA (\GETBASE DAs (IPLUS LASTKNOWNPAGE 1 2)))
                             \FILLINDA)                      (* ; 
                               "There already is an entry for the next page, so no need to read it")
                        (COND
                           ((EQ DA \EOFDA)
                            (RETURN))
                           (T (add LASTKNOWNPAGE 1]
                       (T [SETQ NPAGES (IMIN \MAXDISKDAs (ADD1 (IDIFFERENCE UPTOPAGE LASTKNOWNPAGE]

                          (* ;; "We know where LASTKNOWNPAGE lives, so read it to find out where the next page after that is.  Can do this for many pages at once to make it reasonable")

                          (SETQ LASTPAGEREAD (\ACTONDISKPAGES DSK NIL DAs -1 STREAM (.LISP.TO.BFS.
                                                                                     LASTKNOWNPAGE)
                                                    [SETQ LASTATTEMPTED
                                                     (.LISP.TO.BFS. (SUB1 (IPLUS LASTKNOWNPAGE NPAGES
                                                                                 ]
                                                    \DC.READD))
                          (SETQ LASTKNOWNPAGE (.BFS.TO.LISP. LASTPAGEREAD))
                          (COND
                             ((ILESSP LASTPAGEREAD LASTATTEMPTED)
                                                             (* ; "Hit end of file")
                              (RETURN]
          (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with LASTKNOWNPAGE)
          (RETURN LASTKNOWNPAGE])

(\M44GetFileHandle
  [LAMBDA (NAME RECOG FDEV FAST CREATEFLG)               (* ; "Edited 21-Jan-91 23:48 by jds")

    (* ;; "Creates a STREAM for dsk file NAME.  If file does not exist, but CREATEFLG is true, returns the UNAME of the file so that it may be created.  If FAST is true, does not fill in any fields of STREAM that would require reading the file, e.g., the length and full map")

    (LET ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of FDEV))
          FS DP STREAM)
         (COND
            ((NULL DIRSTREAM)                                (* ; "Non-existent device")
             NIL)
            ((NULL (SETQ FS (\M44PARSEFILENAME NAME RECOG FDEV CREATEFLG)))
                                                             (* ; "File not found")
             NIL)
            ((SETQ DP (fetch (FILESPEC FSDIRPTR) of FS))
                                                             (* ; 
                                                     "File was found--here's the directory pointer")
             (SETQ STREAM (create M44STREAM))
             (replace DEVICE of STREAM with FDEV)
             (replace (M44STREAM FID) of STREAM with (\M44READDIRFID DIRSTREAM DP))
             (replace (M44STREAM DIRINFO) of STREAM with DP)
             (replace FULLFILENAME of STREAM with (\M44PACKFILENAME
                                                               (fetch (FILESPEC UNAME)
                                                                  of FS)
                                                               DP DIRSTREAM))
             (replace MULTIBUFFERHINT of STREAM with \M44MULTFLG)
             (OR FAST (\M44CompleteFH STREAM))
             STREAM)
            ((NULL (fetch (FILESPEC UNAME) of FS))   (* ; 
                                           "Name was malformed--can't create it even if we want to")
             (LISPERROR "BAD FILE NAME" NAME))
            (CREATEFLG (fetch (FILESPEC UNAME) of FS])

(\M44GetFileInfo
  [LAMBDA (STREAM ATTRIBUTE DEV)                         (* ; "Edited 21-Jan-91 23:44 by jds")

    (* ;; "Get the value of the ATTRIBUTE for a model44 file.  If STREAM is a filename, then the file is not open.")

    (COND
       ((OR (type? STREAM STREAM)
            (SETQ STREAM (\M44GetFileHandle STREAM 'OLD DEV T)))
        (SELECTQ ATTRIBUTE
            ((LENGTH SIZE) 
                 (COND
                    ((NULL (fetch VALIDATION of STREAM))
                                                             (* ; 
                                                       "Need to read leader page etc to get length")
                     (\M44CompleteFH STREAM)))
                 (SELECTQ ATTRIBUTE
                     (LENGTH (create BYTEPTR
                                    PAGE _ (fetch EPAGE of STREAM)
                                    OFFSET _ (fetch EOFFSET of STREAM)))
                     (IPLUS (fetch EPAGE of STREAM)
                            (FOLDHI (fetch EOFFSET of STREAM)
                                   BYTESPERPAGE))))
            (TYPE [PROG ((BUF (\M44ReadLeaderPage STREAM)))
                        (RETURN
                         (COND
                            ((IGREATERP (fetch (\M44LeaderPage PropertyLength) of BUF)
                                    0)
                             (SETQ BUF (\ADDBASE BUF (fetch (\M44LeaderPage PropertyBegin)
                                                        of BUF)))
                             (do (SELECTC (fetch (M44FILEPROP FPROPTYPE) of BUF)
                                         (0                  (* ; "End of properties")
                                            (RETURN))
                                         (\FPROP.TYPE [RETURN (SELECTC (fetch (M44FILEPROP 
                                                                                         FPROPWORD0)
                                                                          of BUF)
                                                                  (\FPTYPE.TEXT 'TEXT)
                                                                  (\FPTYPE.BINARY 
                                                                       'BINARY)
                                                                  (\FPTYPE.UNKNOWN 
                                                                       NIL)
                                                                  (\TYPE.FROM.FILETYPE
                                                                   (fetch (M44FILEPROP FPROPWORD0
                                                                                     ) of BUF])
                                         NIL)
                                    (SETQ BUF (\ADDBASE BUF (fetch (M44FILEPROP FPROPLENGTH)
                                                               of BUF])
            (CREATIONDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeCreate)
                                                                 of T))
                                 T))
            (WRITEDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeWrite)
                                                              of T))
                              T))
            (READDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeRead)
                                                             of T))
                             T))
            (ICREATIONDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeCreate)
                                                                  of T))))
            (IWRITEDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeWrite)
                                                               of T))))
            (IREADDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeRead)
                                                              of T))))
            NIL])

(\M44GETDATEPROP
(LAMBDA (STREAM OFFSET STRINGIFY) (* bvm%: "27-May-84 22:57") (* ;; "Returns the create/write/read date of STREAM that lives at OFFSET in its leader page, as a string if STRINGIFY is true, else as a Lisp date fixp") (PROG ((DATEBASE (\ADDBASE (\M44ReadLeaderPage STREAM) OFFSET)) DAT) (SETQ DAT (\MAKENUMBER (\GETBASE DATEBASE 0) (\GETBASE DATEBASE 1))) (RETURN (COND ((NEQ DAT 0) (SETQ DAT (ALTO.TO.LISP.DATE DAT)) (COND (STRINGIFY (GDATE DAT)) (T DAT)))))))
)

(\M44GetFileName
  [LAMBDA (NAME RECOG FDEV)                              (* ; "Edited 21-Jan-91 23:48 by jds")
    (LET ((FS (\M44PARSEFILENAME NAME RECOG FDEV))
          DP UNAME)
         (AND FS (SETQ UNAME (fetch (FILESPEC UNAME) of FS))
              (\M44PACKFILENAME UNAME (SETQ DP (fetch (FILESPEC FSDIRPTR) of FS))
                     (AND DP (fetch (M44DEVICE SYSDIROFD) of FDEV])

(\M44GetPageLoc
  [LAMBDA (STREAM PAGENO CREATE?)                        (* ; "Edited 21-Jan-91 23:35 by jds")

    (* ;; "Look in the file's page map to find the disk address of the page.  If the map does not include the page, then extend it appropriately.  If page does not exit, create it if CREATE?  is true, else return \EOFDA")

    (COND
       ((ILEQ PAGENO (fetch (M44STREAM LastPage) of STREAM))
        (COND
           ((IGREATERP PAGENO (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
            (\M44FillInMap STREAM PAGENO)))
        (\WORDELT (fetch (M44STREAM FILEPAGEMAP) of STREAM)
               (IPLUS PAGENO 2)))
       (CREATE? (\M44AddDiskPages STREAM PAGENO 0)
              (\M44GetPageLoc STREAM PAGENO))
       (T \EOFDA])

(\M44KillFilePageMap
  [LAMBDA (fHandle)                                      (* ; "Edited 21-Jan-91 23:35 by jds")
                                                             (* ; "Remove the file's page map.")
    (replace (M44STREAM FILEPAGEMAP) of fHandle with NIL)
    (replace (M44STREAM LASTMAPPEDPAGE) of fHandle with -1])

(\M44MAKEDIRENTRY
  [LAMBDA (FID UNAME NC FDEV)                            (* ; "Edited 21-Jan-91 23:38 by jds")

    (* ;; "Makes a directory entry for a new file.  FID is file's ID, NC the number of characters in the full Alto name.")

    (PROG ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of FDEV))
           (VERSION (fetch (UNAME VERSION) of UNAME))
           POS)
          (SETQ POS (\FINDDIRHOLE (LRSH (IPLUS NC 14)
                                            1)
                           DIRSTREAM))
          (\BOUTS DIRSTREAM (fetch (FID FIDBLOCK) of FID)
                 0
                 (UNFOLD 5 BYTESPERWORD))
          (\BOUT DIRSTREAM NC)

     (* ;; "Now write out the alto-style name 'name[.ext]!ver.' with ver omitted if 1;  This is basically the same logic as is used to write the name in the leader page in \M44CREATEFILE.  We can't share cause here we do bouts, cause we might run over a page;  there we must do PUTBASEBYTE's cause we can't set the fileptr to the leader page.")

          (for C in (fetch (UNAME ORIGCHARS) of UNAME) do (\BOUT DIRSTREAM C))
          [COND
             ((NEQ VERSION 1)
              (\BOUT DIRSTREAM (CHARCODE !))
              (LET ((*PRINT-BASE* 10))
                   (PRIN3 VERSION DIRSTREAM]
          (\BOUT DIRSTREAM (CHARCODE %.))
          (COND
             ((EVENP NC BYTESPERWORD)
              (\BOUT DIRSTREAM 0)))
          (\SETFILEPTR DIRSTREAM POS)
          (\BOUT DIRSTREAM (LOGOR 4 (\PEEKBIN DIRSTREAM)))   (* ; 
                             "When everything is ready, finally change the type from hole to file.")
          (FORCEOUTPUT DIRSTREAM)
          (RETURN POS])

(\M44OpenFile
  [LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM)  (* ; "Edited 21-Jan-91 23:38 by jds")

    (* ;; "Open a Model44 file.  Gets the physical end of file and sets up ofd")

    (PROG (PAGESTIMATE STREAM CRDATE TYPE DON'T.CHANGE.DATE X)
                                                             (* ; 
                                                       "if file is open in a conflicting way, barf")
          [COND
             ((NEQ ACCESS 'INPUT)                            (* ; 
                                                      "Interesting parameters when creating a file")
              (for X in PARAMETERS do (SELECTQ (CAR (LISTP X))
                                                      (LENGTH (SETQ PAGESTIMATE
                                                               (IPLUS 2 (FOLDHI (CADR X)
                                                                               BYTESPERPAGE))))
                                                      (CREATIONDATE (SETQ CRDATE (IDATE (CADR X))))
                                                      (ICREATIONDATE (SETQ CRDATE (CADR X)))
                                                      (TYPE (SETQ TYPE (CADR X)))
                                                      (DON'T.CHANGE.DATE 
                                                           (SETQ DON'T.CHANGE.DATE T))
                                                      NIL]
          (COND
             [(type? STREAM NAME)
              (COND
                 ((OR (fetch (M44DEVICE DSKPASSWORDOK) of (fetch DEVICE of NAME))
                      (EQ (fetch (FID W0) of (fetch (M44STREAM FID) of NAME))
                          32768))                            (* ; 
                            "Make sure password is ok if trying to reopen anything but a directory")
                  (\M44CompleteFH (SETQ STREAM NAME)))
                 (T (RETURN]
             ([NULL (SETQ STREAM (\M44GetFileHandle NAME RECOG FDEV NIL (NEQ ACCESS 'INPUT]
                                                             (* ; 
                  "File not found.  Return NIL to let generic open generate a FILE NOT FOUND error")
              (RETURN NIL)))
          (if OLDSTREAM
              then                                       (* ; "REOPENFILE--nothing more to do")
                    (RETURN STREAM))
          [COND
             ([AND PAGESTIMATE (IGREATERP PAGESTIMATE (IPLUS (fetch (M44DEVICE DISKFREEPAGES)
                                                                of FDEV)
                                                             (COND
                                                                ((type? STREAM STREAM)
                                                                 (fetch (M44STREAM LastPage)
                                                                    of STREAM))
                                                                (T 
                                                             (* ; "New file")
                                                                   0]
              (RETURN (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" (COND
                                                                     ((type? STREAM STREAM)
                                                                      (fetch FULLFILENAME
                                                                         of STREAM))
                                                                     (T NAME]
          [COND
             (CRDATE                                         (* ; "Convert to alto format")
                    (COND
                       ([NOT (type? FIXP (SETQ CRDATE (LISP.TO.ALTO.DATE CRDATE]
                                                             (* ; "sigh, wanted a number box")
                        (\PUTBASEFIXP (SETQ X (create FIXP))
                               0 CRDATE)
                        (SETQ CRDATE X]
          [COND
             ((NOT (type? STREAM STREAM))                (* ; "New file")
              (SETQ STREAM (\M44CREATEFILE FDEV STREAM PAGESTIMATE CRDATE TYPE)))
             (T                                              (* ; "Old file")
                [LET ((MYNAME (fetch FULLFILENAME of STREAM)))
                     (COND
                        ([for OTHER in (fetch (FDEV OPENFILELST) of FDEV)
                            when (STRING-EQUAL (fetch FULLFILENAME of OTHER)
                                            MYNAME)
                            do (RETURN (OR (NEQ ACCESS 'INPUT)
                                               (NEQ (fetch ACCESS of OTHER)
                                                    'INPUT]  (* ; 
                                                          "Access conflict with existing open file")
                         (RETURN (LISPERROR "FILE WON'T OPEN" MYNAME]
                [COND
                   ((EQ ACCESS 'OUTPUT)                      (* ; "File is EMPTY even if it is old")
                    (replace EPAGE of STREAM with (replace EOFFSET of STREAM
                                                                 with 0]
                                                             (* ; 
                                              "Leader page is read in during STREAM initialization")
                (COND
                   ((NOT DON'T.CHANGE.DATE)
                    (\M44SetAccessTimes STREAM ACCESS CRDATE)
                                                             (* ; "Resets validation")
                    (\M44WriteLeaderPage STREAM)         (* ; 
                                                  "We write out accumulated changes to leader page")
                    ]
          (COND
             (CRDATE (replace NONDEFAULTDATEFLG of STREAM with T)))
          (RETURN STREAM])

(\M44OPENFILEFROMFP
  [LAMBDA (DEV NAME ACCESS FID DIRINFO)                  (* ; "Edited 21-Jan-91 23:36 by jds")
                                                             (* ; "Opens a disk file given its FP")
    (LET ((STREAM (create M44STREAM)))
         (replace FULLFILENAME of STREAM with (SETQ NAME (PACK* '{ (fetch
                                                                                (FDEV DEVICENAME)
                                                                                  of DEV)
                                                                            '} NAME)))
         (replace DEVICE of STREAM with DEV)
         (replace (M44STREAM FID) of STREAM with FID)
         (replace (M44STREAM DIRINFO) of STREAM with DIRINFO)
         (replace MULTIBUFFERHINT of STREAM with \M44MULTFLG)
         (\OPENFILE STREAM ACCESS)
         (replace USERVISIBLE of STREAM with NIL)
         STREAM])

(\M44ReadDiskPage
  [LAMBDA (STREAM PAGENO BUF)                            (* ; "Edited 21-Jan-91 23:42 by jds")

    (* ;; "The functions for reading a disk page called by \M44ReadPages.  Returns the number of bytes read.  If PAGEADDR is 0, then assume 0 bytes read.  Fill the BUF with zeros beyond the last byte read.")

    (COND
       ((AND (IGEQ PAGENO (fetch EPAGE of STREAM))
             (OR (NOT (IEQP PAGENO (fetch EPAGE of STREAM)))
                 (EQ (fetch EOFFSET of STREAM)
                     0)))                                    (* ; 
                        "Asking for page after eof.  PMAP system really ought to catch this itself")
        (\CLEARWORDS BUF WORDSPERPAGE)
        0)
       (T (PROG ((PAGEADDR (\M44GetPageLoc STREAM PAGENO))
                 (BFSPG# (ADD1 PAGENO)))
                (RETURN (COND
                           ((EQ PAGEADDR \EOFDA)             (* ; 
                                                           "no bytes read, fill with zeroes.")
                            (\CLEARWORDS BUF WORDSPERPAGE)
                            0)
                           ((EQ PAGEADDR \FILLINDA)
                            (SHOULDNT))
                           ((EQ (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ)
                                                    of (fetch DEVICE of STREAM))
                                       BUF
                                       (fetch (ARRAYP BASE) of (fetch (M44STREAM 
                                                                                         FILEPAGEMAP)
                                                                          of STREAM))
                                       -1 STREAM BFSPG# BFSPG# \DC.READD)
                                BFSPG#)
                            BYTESPERPAGE)
                           (T 
                              (* ;; "if READDISKPAGE returns NIL, presumably there is an error of some kind, hope it was with the file map and try again.")

                              (\M44KillFilePageMap STREAM)
                              (\M44ReadDiskPage STREAM PAGENO BUF])

(\M44ReadLeaderPage
  [LAMBDA (STREAM AGAIN)                                 (* ; "Edited 21-Jan-91 23:42 by jds")

(* ;;; "Returns the leader page of STREAM, reading it if necessary.  If AGAIN is true, will read it afresh even if it already has a cached leader page")

    (* ;; "File leader page format: Words 0-1, time created.  Words 2-3, time last written.  Words 4-5, time last read.  Words 6-25, name of file.  Words 26-235, leader properties.  Words 236-245, spare.  Word 246, property pointer.  Word 247, change serial number.  Words 248-252, STREAM hint for directory.  Word 253, disk address of last page.  Word 254, page number of last page.  Word 255, number of bytes on last page.")

    (PROG ((BUFFER (fetch (M44STREAM LEADERPAGE) of STREAM)))
          (COND
             [(NULL BUFFER)
              (SETQ BUFFER (NCREATE 'VMEMPAGEP]
             ((NOT AGAIN)
              (RETURN BUFFER)))
          (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM))
                 BUFFER
                 (fetch (ARRAYP BASE) of (OR (fetch (M44STREAM FILEPAGEMAP) of STREAM
                                                            )
                                                     (\MAKELEADERDAS STREAM)))
                 -1 STREAM 0 0 \DC.READD)
          (replace (M44STREAM LEADERPAGE) of STREAM with BUFFER)
          (RETURN BUFFER])

(\M44ReadPages
(LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* bvm%: "26-DEC-81 23:50") (* ; "Read pages from a Model44 file.") (for BUF inside BUFFERS as PAGENO from FIRSTPAGE# sum (\M44ReadDiskPage STREAM PAGENO BUF)))
)

(\M44SetAccessTimes
  [LAMBDA (STREAM ACCESS CRDATE)                         (* ; "Edited 21-Jan-91 23:36 by jds")

(* ;;; "Set the 'last read' and/or 'last written' times in the leader page according to access, which is assumed to be either INPUT, OUTPUT, BOTH, or APPEND.")

    (PROG ((DAT (\DAYTIME0 (create FIXP)))
           (BUF (fetch (M44STREAM LEADERPAGE) of STREAM)))

     (* ;; "Note: DAYTIME0 returns an Alto time, not Lisp time.  This is consistent with the dates in the leader page")

          (SELECTQ ACCESS
              ((OUTPUT BOTH APPEND) 
                   (\BLT (LOCF (fetch (\M44LeaderPage TimeCreate) of BUF))
                         (OR CRDATE DAT)
                         WORDSPERCELL)
                   (\BLT (LOCF (fetch (\M44LeaderPage TimeWrite) of BUF))
                         DAT WORDSPERCELL)                   (* ; 
                                                    "Must revalidate because write DAT has changed")
                   (UPDATEVALIDATION STREAM BUF))
              NIL)
          (SELECTQ ACCESS
              ((INPUT BOTH) 
                   (\BLT (LOCF (fetch (\M44LeaderPage TimeRead) of BUF))
                         DAT WORDSPERCELL))
              NIL])

(\M44SetEndOfFile
  [LAMBDA (STREAM EPAGE EOFFSET UPDATENOW)               (* ; "Edited 21-Jan-91 23:36 by jds")

    (* ;; "Reset the file's leader page end-of-file hint.  If UPDATENOW is NIL, then simply update the leader page.  If it is not, then read and write the leader page.")

    (UNINTERRUPTABLY
        
        (* ;; "Must update STREAM handle and leader page in synch")

        (replace (M44STREAM LastPage) of STREAM with EPAGE)
        (replace (M44STREAM LastOffset) of STREAM with EOFFSET)
        [LET ((LEADERPAGE (\M44ReadLeaderPage STREAM)))
             (if (NEQ (fetch (\M44LeaderPage LastPageNumber) of LEADERPAGE)
                          (ADD1 EPAGE))
                 then                                    (* ; 
                                                    "if LastPage hasn't changed, don't do anything")
                                                             (* ; "ADD1 because M44 counts from 1")
                       (replace (\M44LeaderPage LastPageAddress) of LEADERPAGE
                          with (\M44GetPageLoc STREAM EPAGE))
                       (replace (\M44LeaderPage LastPageNumber) of LEADERPAGE
                          with (ADD1 EPAGE)))
             (replace (\M44LeaderPage LastPageByteCount) of LEADERPAGE with EOFFSET)
             (COND
                (UPDATENOW (\M44WriteLeaderPage STREAM])])

(\M44SetFileInfo
  [LAMBDA (STREAM ATTRIBUTE VALUE DEV)                   (* ; "Edited 21-Jan-91 23:34 by jds")
    (PROG ((WASOPEN (type? STREAM STREAM)))
          (SELECTQ ATTRIBUTE
              (CREATIONDATE (SETQ VALUE (OR (IDATE VALUE)
                                            (LISPERROR "ILLEGAL ARG" VALUE))))
              (ICREATIONDATE (OR (FIXP VALUE)
                                 (LISPERROR "NON-NUMERIC ARG" VALUE)))
              (TYPE)
              (RETURN))
          (RETURN (COND
                     ((OR WASOPEN (SETQ STREAM (\M44GetFileHandle STREAM 'OLD DEV T)))
                      (COND
                         ((SELECTQ ATTRIBUTE
                              (TYPE (\M44SETFILETYPE STREAM VALUE))
                              (PROGN (replace (\M44LeaderPage TimeCreate) of (
                                                                                 \M44ReadLeaderPage
                                                                                      STREAM)
                                        with (LISP.TO.ALTO.DATE VALUE))
                                     T))
                          (\M44WriteLeaderPage STREAM)
                          T])

(\M44SETFILETYPE
  [LAMBDA (STREAM TYPE)                                  (* ; "Edited 21-Jan-91 23:44 by jds")

    (* ;; "Set TYPE attribute of file to be TYPE -- assumes someone else will be writing out the leader page later")

    (PROG ((TYPECODE (SELECTQ TYPE
                         (TEXT \FPTYPE.TEXT)
                         (BINARY \FPTYPE.BINARY)
                         (NIL \FPTYPE.UNKNOWN)
                         (OR (\FILETYPE.FROM.TYPE TYPE)
                             \FPTYPE.BINARY)))
           (BUF (\M44ReadLeaderPage STREAM))
           PTR TOTALLENGTH)

     (* ;; "Computation of TYPECODE done this way for backward compatibility -- the \FPTYPE.xx constants were defined before \FILETYPE.FROM.TYPE was written, and the numbers are incompatible")

          (SETQ PTR (\ADDBASE BUF (fetch (\M44LeaderPage PropertyBegin) of BUF)))
          (SETQ TOTALLENGTH (fetch (\M44LeaderPage PropertyLength) of BUF))
          (RETURN (while (IGREATERP TOTALLENGTH 0)
                     do (SELECTC (fetch (M44FILEPROP FPROPTYPE) of PTR)
                                (0                           (* ; "End of properties")
                                   (RETURN (COND
                                              ((IGREATERP TOTALLENGTH 1)
                                               (replace (M44FILEPROP FPROPWORD0) of PTR
                                                  with TYPECODE)
                                               (replace (M44FILEPROP FPROPLENGTH) of PTR
                                                  with 2)
                                               (replace (M44FILEPROP FPROPTYPE) of PTR
                                                  with \FPROP.TYPE)
                                               T))))
                                (\FPROP.TYPE                 (* ; "Already has a type, change it")
                                             (replace (M44FILEPROP FPROPWORD0) of PTR
                                                with TYPECODE)
                                             (RETURN T))
                                NIL)
                           (SETQ PTR (\ADDBASE PTR (fetch (M44FILEPROP FPROPLENGTH) of PTR)))
                           (SETQ TOTALLENGTH (IDIFFERENCE TOTALLENGTH (fetch (M44FILEPROP 
                                                                                        FPROPLENGTH)
                                                                         of PTR])

(\M44TruncateFile
  [LAMBDA (STREAM LP LO UPDATENOW)                       (* ; "Edited 21-Jan-91 23:36 by jds")

    (* ;; 
  "Resets the length of the file to LP page and LO offset.  Can both shorten and lengthen files.")

    [COND
       ((NOT LP)
        (SETQ LP (fetch EPAGE of STREAM))
        (SETQ LO (fetch EOFFSET of STREAM]
    (COND
       ((IGREATERP LP (fetch (M44STREAM LastPage) of STREAM))
        (\M44AddDiskPages STREAM LP LO))
       ((ILESSP LP (fetch (M44STREAM LastPage) of STREAM))
        (\M44DELETEPAGES STREAM (ADD1 LP))
        (COND
           ((ILESSP LP (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM))
            (for I from (ADD1 LP) to (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)
               do (SETA (fetch (M44STREAM FILEPAGEMAP) of STREAM)
                            (IPLUS I 2)
                            \EOFDA))
            (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with LP)))
        (\M44SetEndOfFile STREAM LP LO)                  (* ; 
                                 "Now need to rewrite last page with new length, null next pointer")
        (\MAPPAGE LP STREAM)
        (\SETIODIRTY STREAM LP)
        (FORCEOUTPUT STREAM))
       (T (replace (M44STREAM LastOffset) of STREAM with LO)))
    (AND UPDATENOW (\M44SetEndOfFile STREAM LP LO T))
    STREAM])

(\M44WriteDiskPage
  [LAMBDA (STREAM PAGENO BUF NBYTES)                     (* ; "Edited 21-Jan-91 23:42 by jds")
                                                             (* ; 
                                                           "Write a disk page on the Model44.")
    (\M44GetPageLoc STREAM PAGENO T)                     (* ; "Ensure that PAGENO is in map")
    (PROG ((BFSPG# (ADD1 PAGENO)))
          (RETURN (COND
                     ([COND
                         ((NEQ PAGENO (fetch (M44STREAM LastPage) of STREAM))
                                                             (* ; "Writing only data")
                          (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE
                                                                                   of STREAM))
                                 BUF
                                 (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP)
                                                                    of STREAM))
                                 -1 STREAM BFSPG# BFSPG# \DC.WRITED))
                         (T                                  (* ; 
           "When writing last page, need to fill in the numchars field of label, so this is harder")
                            (COND
                               ((EQ PAGENO (fetch EPAGE of STREAM))
                                (EQ (\WRITEDISKPAGES (fetch (M44DEVICE DSKOBJ)
                                                        of (fetch DEVICE of STREAM))
                                           BUF
                                           (fetch (ARRAYP BASE) of (fetch (M44STREAM
                                                                                       FILEPAGEMAP)
                                                                              of STREAM))
                                           -1 STREAM BFSPG# BFSPG# NIL NIL NBYTES)
                                    BFSPG#))
                               (T 

                                 (* ;; "We will have to write more pages after this one, too, unless the file is truncated back to here, so extend the file while we're at it.  This may save a call to \ADDDISKPAGES")

                                  [COND
                                     ((ILEQ (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)
                                            PAGENO)
                                      (\M44ExtendFilePageMap STREAM (ADD1 PAGENO]
                                  (COND
                                     ((EQ (\WRITEDISKPAGES (fetch (M44DEVICE DSKOBJ)
                                                              of (fetch DEVICE of STREAM)
                                                                  )
                                                 (LIST BUF NIL)
                                                 (fetch (ARRAYP BASE) of (fetch
                                                                                  (M44STREAM 
                                                                                         FILEPAGEMAP)
                                                                                    of STREAM))
                                                 -1 STREAM BFSPG# (ADD1 BFSPG#)
                                                 NIL NIL 0)
                                          (ADD1 BFSPG#))     (* ; 
                                                    "Write two pages, the second of which is blank")
                                      (replace (M44STREAM LastPage) of STREAM
                                         with (ADD1 PAGENO))
                                      (replace (M44STREAM LastOffset) of STREAM with
                                                                                        0)
                                      T]
                      NBYTES)
                     (T (\M44KillFilePageMap STREAM)
                        (\M44WriteDiskPage STREAM PAGENO BUF NBYTES])

(\M44WriteLeaderPage
  [LAMBDA (STREAM)                                       (* ; "Edited 21-Jan-91 23:42 by jds")
                                                             (* ; "Write the file's leader page")
    (PROG ((BUFFER (fetch (M44STREAM LEADERPAGE) of STREAM)))
          (AND BUFFER (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE
                                                                               of STREAM))
                             BUFFER
                             (fetch (ARRAYP BASE) of (OR (fetch (M44STREAM FILEPAGEMAP)
                                                                    of STREAM)
                                                                 (\MAKELEADERDAS STREAM)))
                             -1 STREAM 0 0 \DC.WRITED])

(\M44WritePages
  [LAMBDA (STREAM FIRSTPAGE# BUFFERS)                    (* ; "Edited 21-Jan-91 23:36 by jds")
                                                             (* ; 
                                                           "Write pages onto a Model44 file.")
    (PROG ([NPAGES (COND
                      ((NLISTP BUFFERS)
                       1)
                      (T (for B in BUFFERS sum 1]
           LASTPAGE#)
          (COND
             ((fetch REVALIDATEFLG of STREAM)

              (* ;; "Need to update creationdate, since a SAVEVM etc has occurred since the last write.  Otherwise, it is possible to see a change to the file but no change to the creationdate")

              (\M44SetAccessTimes STREAM 'OUTPUT)
              (\M44WriteLeaderPage STREAM)
              (replace REVALIDATEFLG of STREAM with NIL)))
          (\M44GetPageLoc STREAM FIRSTPAGE# T)           (* ; 
                                                 "Make sure we know where we are starting to write")
          [COND
             ([ILESSP (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)
                     (SETQ LASTPAGE# (IPLUS FIRSTPAGE# (SUB1 NPAGES]
                                                             (* ; 
                                                 "Need enough pagemap to cover everything we write")
              (\M44ExtendFilePageMap STREAM (ADD1 LASTPAGE#]
          [COND
             ([AND (IGEQ NPAGES \#DISKBUFFERS)
                   (for B in BUFFERS thereis (NOT (EMADDRESSP B]

              (* ;; "More pages to write than we have disk buffers to do it in one command, so break it up.  Buffers already in emulator space are free, though, so we can write lots of them")

              (bind (MAXPAGES _ (SUB1 \#DISKBUFFERS))
                 do (\M44WritePages1 STREAM FIRSTPAGE# (IPLUS FIRSTPAGE# (SUB1 MAXPAGES))
                               (to MAXPAGES collect (pop BUFFERS)))
                       (add FIRSTPAGE# MAXPAGES)
                       (SETQ NPAGES (IDIFFERENCE NPAGES MAXPAGES)) repeatwhile (IGREATERP NPAGES
                                                                                          MAXPAGES]
          (\M44WritePages1 STREAM FIRSTPAGE# LASTPAGE# BUFFERS])

(\M44WritePages1
  [LAMBDA (STREAM FIRSTPAGE# LASTPAGE# BUFFERS)          (* ; "Edited 21-Jan-91 23:42 by jds")

(* ;;; "Writes BUFFERS to STREAM, covering pages FIRSTPAGE# thru LASTPAGE#.  Caller guarantees that we have enough disk buffers to do it.  --- There are two cases: easy one is if the pages already exist, in which case we just rewrite their data;  hard case is writing pages at end of file, in which case we need to write labels and maybe allocate pages")

    (COND
       ((ILESSP LASTPAGE# (fetch (M44STREAM LastPage) of STREAM))
                                                             (* ; "Writing only data")
        (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM))
               BUFFERS
               (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP) of STREAM))
               -1 STREAM (.LISP.TO.BFS. FIRSTPAGE#)
               (.LISP.TO.BFS. LASTPAGE#)
               \DC.WRITED))
       (T                                                    (* ; 
           "When writing last page, need to fill in the numchars field of label, so this is harder")
          (PROG (MYBUFS NBYTES)
                [SETQ MYBUFS (COND
                                ((AND (EQ LASTPAGE# (fetch EPAGE of STREAM))
                                      (NEQ (SETQ NBYTES (fetch EOFFSET of STREAM))
                                           BYTESPERPAGE))    (* ; 
                                                           "Only write to the end of the file")
                                 BUFFERS)
                                (T 

                                 (* ;; "We will have to write more pages after this one, too, unless the file is truncated back to here, so extend the file while we're at it.  This may save a call to \ADDDISKPAGES")

                                   (PROG1 (SETQ MYBUFS (CONS))
                                       [for B inside BUFFERS
                                          do (RPLACA MYBUFS B)
                                                (SETQ MYBUFS (CDR (RPLACD MYBUFS (CONS]
                                       (RPLACD (RPLACA MYBUFS NIL)
                                              NIL)           (* ; "Write a final blank page")
                                       (SETQ NBYTES 0)
                                       (add LASTPAGE# 1))]
                (\WRITEDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM
                                                                             ))
                       MYBUFS
                       (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP)
                                                          of STREAM))
                       -1 STREAM (.LISP.TO.BFS. FIRSTPAGE#)
                       (.LISP.TO.BFS. LASTPAGE#)
                       NIL NIL NBYTES)
                (replace (M44STREAM LastPage) of STREAM with LASTPAGE#)
                (replace (M44STREAM LastOffset) of STREAM with NBYTES])
)



(* ;; "Disk allocation")

(DEFINEQ

(\ADDDISKPAGES
  [LAMBDA (STREAM FIRSTNEWPAGE NPAGES DAs LASTNUMCHARS)  (* ; "Edited 21-Jan-91 23:42 by jds")

    (* ;; "Adds to file STREAM NPAGES, where FIRSTNEWPAGE-1 is the last existing page.  DAs is the vector of disk addresses, where first element corresponds to BFS page -1")
                                                             (* ; 
                    "Note FIRSTNEWPAGE is in Lisp terms, so it is actually LASTOLDPAGE for the BFS")
    (PROG ((LASTPAGEBUF (NCREATE 'VMEMPAGEP))
           (LASTEXISTINGPAGE FIRSTNEWPAGE)
           (DSK (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)))
           BUFFERS CHUNK)
          (SETQ BUFFERS (CONS LASTPAGEBUF (for I from 1 to (IMIN NPAGES \MAXDISKDAs)
                                             collect NIL)))
          (\ACTONDISKPAGES DSK LASTPAGEBUF DAs -1 STREAM LASTEXISTINGPAGE LASTEXISTINGPAGE \DC.READD
                 NIL NIL NIL LASTEXISTINGPAGE)               (* ; 
                                     "Read last existing page, so we can rewrite it with new label")
          (while (IGREATERP NPAGES 0) do (SETQ CHUNK (IMIN \MAXDISKDAs NPAGES))
                                                (\WRITEDISKPAGES DSK BUFFERS DAs -1 STREAM 
                                                       LASTEXISTINGPAGE (IPLUS LASTEXISTINGPAGE CHUNK
                                                                               )
                                                       NIL NIL LASTNUMCHARS LASTEXISTINGPAGE)
                                                (RPLACA BUFFERS NIL)
                                                (add LASTEXISTINGPAGE CHUNK)
                                                (SETQ NPAGES (IDIFFERENCE NPAGES CHUNK])

(\M44DELETEPAGES
  [LAMBDA (STREAM FIRSTPAGE)                             (* ; "Edited 21-Jan-91 23:42 by jds")
                                                             (* ; 
                                               "FIRSTPAGE is in Lisp terms, i.e.  -1 = leader page")
    (PROG ((DEV (fetch DEVICE of STREAM))
           (NPAGES (COND
                      ((fetch VALIDATION of STREAM)
                       (IPLUS (ADD1 (IDIFFERENCE (fetch (M44STREAM LastPage) of STREAM)
                                           FIRSTPAGE))
                              2))
                      (T PageMapIncrement)))
           (PN (ADD1 FIRSTPAGE))
           DAs FIRSTDA LASTPAGESEEN DSK)

     (* ;; "NPAGES is used to decide how much to do at once.  Need be no more than number of pages known to exist.  The ADD1 is that, plus two for the pages around it")

          (COND
             ((ILESSP NPAGES 2)                              (* ; "Nothing to delete")
              (RETURN)))
          (SETQ DSK (fetch (M44DEVICE DSKOBJ) of DEV))
                                                             (* (\FLUSHDISKDESCRIPTOR
                                                           (EMPOINTER (fetch (DSKOBJ DSKDDMGR) 
                                                           of DSK)) (fetch (DSKOBJ ALTODSKOBJ) 
                                                           of DSK)))
                                                             (* ; 
                                                "Tell Alto to clear out anything it knows about dd")
                                                             (* ; 
         "IF STREAM:LASTMAPPEDPAGE GE FIRSTPAGE+NPAGES THEN DAs _ STREAM:FILEPAGEMAP DAorigin _ -1")
          (SETQ DAs (ARRAY (SETQ NPAGES (IMIN NPAGES \MAXDISKDAs))
                           'WORD NIL 0))
          [SETQ FIRSTDA (COND
                           [(EQ FIRSTPAGE -1)
                            (fetch (FP FPLEADERVDA) of (fetch (FID FIDBLOCK)
                                                                  of (fetch (M44STREAM FID)
                                                                            of STREAM]
                           (T (\M44GetPageLoc STREAM FIRSTPAGE]
          (while (NEQ FIRSTDA \EOFDA)
             do (SETA DAs 0 \FILLINDA)
                   (SETA DAs 1 FIRSTDA)                      (* ; "Corresponds to PN")
                   (for I from 2 to (SUB1 NPAGES) do (SETA DAs I \FILLINDA))
                   [SETQ LASTPAGESEEN (\ACTONDISKPAGES DSK NIL (fetch (ARRAYP BASE) of DAs)
                                             (SUB1 PN)
                                             STREAM PN (IPLUS PN NPAGES -3)
                                             \DC.READD NIL NIL NIL (ADD1 (fetch EPAGE
                                                                            of STREAM] 
                                                             (* ; "Read DAs for the next NPAGES-2")
                   (\WRITEDISKPAGES DSK NIL (fetch (ARRAYP BASE) of DAs)
                          (SUB1 PN)
                          \FREEPAGEFID PN LASTPAGESEEN (UNSIGNED -1 BITSPERWORD))
                   [for I from PN to LASTPAGESEEN
                      do (\M44MARKPAGEFREE DEV (ELT DAs (ADD1 (IDIFFERENCE I PN]
                   (SETQ FIRSTDA (ELT DAs (IPLUS (IDIFFERENCE LASTPAGESEEN PN)
                                                 2)))
                   (SETQ PN (ADD1 LASTPAGESEEN)))            (* (FLUSHMAP (fetch
                                                           (M44DEVICE DISKDESCRIPTOROFD) of DEV))
                                                           (FORGETPAGES (fetch
                                                           (M44DEVICE DISKDESCRIPTOROFD) of DEV)))
          (\M44FLUSHDISKDESCRIPTOR DEV])

(\ASSIGNDISKPAGE
  [LAMBDA (DSK PREVDA)                                   (* ; "Edited 21-Jan-91 23:32 by jds")

(* ;;; "Assigns a new page on DSK.  If PREVDA is \EOFDA will pick random page, otherwise will attempt to allocate PREVDA+1.  Returns NIL if disk is full")

    (PROG ([VDA (COND
                   ((OR (EQ PREVDA \EOFDA)
                        (COND
                           ((EQ PREVDA \FILLINDA)
                            (AND \DISKDEBUG (RAID 
                                "[Disk debug] \ASSIGNDISKPAGE called with \FILLINDA.  ^N to continue"
                                                  ))
                            T)))
                    (fetch (DSKOBJ DISKLASTPAGEALLOC) of DSK))
                   (T (ADD1 PREVDA]
           (DD (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSK))
           (MASK 128)
           BITS A LOOPEDONCE FREE)
          (OR (fetch (DSKOBJ DDVALID) of DSK)
              (RAID "DISKDESCRIPTOR not open" DSK))
          (\SETFILEPTR DD (IPLUS \DDBITTABSTART (FOLDLO VDA BITSPERBYTE)))
          (SETQ A (MOD VDA BITSPERBYTE))
          (FRPTQ A (SETQ MASK (LRSH MASK 1)))
      LP  (COND
             ((NULL (SETQ BITS (\BIN DD)))

              (* ;; "End of file -- wrap around to start.  This technique takes longer than necessary to bomb out when disk is full, but who cares?")

              (COND
                 (LOOPEDONCE (RETURN NIL)))
              (SETQ LOOPEDONCE T)
              (\SETFILEPTR DD \DDBITTABSTART))
             ((NEQ BITS 255)
              (until (OR (EQ (LOGAND BITS MASK)
                                 0)
                             (EQ (SETQ MASK (LRSH MASK 1))
                                 0)) do (add A 1))
              (COND
                 ((NEQ MASK 0)                               (* ; "Found a free page")
                  (\BACKFILEPTR DD)
                  (SETQ VDA (IPLUS (UNFOLD (IDIFFERENCE (\GETFILEPTR DD)
                                                  \DDBITTABSTART)
                                          BITSPERBYTE)
                                   A))
                  (\BOUT DD (LOGOR BITS MASK))               (* ; 
                                                          "Set bit indicating we snarfed this page")
                                                             (* ; "Decrement free page count hint")
                  [replace (DSKOBJ DISKFREEPAGES) of DSK
                     with (COND
                                 ((EQ (SETQ FREE (fetch (DSKOBJ DISKFREEPAGES) of DSK))
                                      0)
                                  (AND \DISKDEBUG (RAID 
                                         "[Disk debug] Free page hint went negative.  ^N to continue"
                                                        ))
                                  (\COUNTDISKFREEPAGES DD))
                                 (T (SUB1 FREE]
                  (replace (DSKOBJ DISKLASTPAGEALLOC) of DSK with VDA)
                  (replace (DSKOBJ DDDIRTY) of DSK with T)
                  (RETURN VDA)))
              (SETQ MASK 128)
              (SETQ A 0)))
          (GO LP])

(\COUNTDISKFREEPAGES
(LAMBDA (DD) (* bvm%: "13-Feb-85 19:32") (* ;;; "Counts number of free pages on a disk.  DD is the diskdescriptor stream") (OR (type? STREAM DD) (SETQ DD (\OPENDISKDESCRIPTOR (\GETDEVICEFROMNAME (OR DD (QUOTE DSK)))))) (PROG ((CNT 0) MASK BITS) (\SETFILEPTR DD \DDBITTABSTART) LP (COND ((NULL (SETQ BITS (\BIN DD))) (* ; "End of file") (RETURN CNT)) ((EQ BITS 0) (add CNT 8)) ((NEQ BITS 255) (SETQ MASK 128) (do (COND ((EQ (LOGAND BITS MASK) 0) (add CNT 1))) until (EQ (SETQ MASK (LRSH MASK 1)) 0)))) (GO LP)))
)

(\M44MARKPAGEFREE
(LAMBDA (DEV DA) (* bvm%: "17-Jan-85 17:11") (* ;; "Mark disk address DA on disk device DEV free") (PROG ((DSK (COND ((type? FDEV DEV) (fetch (M44DEVICE DSKOBJ) of DEV)) (T DEV))) DD BITS MASK) (SETQ DD (COND ((fetch (DSKOBJ DDVALID) of DSK) (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSK)) (T (\OPENDISKDESCRIPTOR DEV)))) (SETFILEPTR DD (IPLUS \DDBITTABSTART (FOLDLO DA BITSPERBYTE))) (SETQ BITS (\BIN DD)) (SETQ MASK (LLSH 1 (IDIFFERENCE 7 (MOD DA BITSPERBYTE)))) (COND ((NEQ (LOGAND BITS MASK) 0) (* ; "Page is marked occupied, so free it") (\BACKFILEPTR DD) (\BOUT DD (LOGXOR BITS MASK)) (add (fetch (DSKOBJ DISKFREEPAGES) of DSK) 1) (replace (DSKOBJ DDDIRTY) of DSK with T)))))
)

(\M44FLUSHDISKDESCRIPTOR
  [LAMBDA (DEV)                                          (* ; "Edited 21-Jan-91 23:32 by jds")
    (PROG ((DSK (COND
                   ((type? FDEV DEV)
                    (fetch (M44DEVICE DSKOBJ) of DEV))
                   (T DEV)))
           DD)
          (OR (fetch (DSKOBJ DDDIRTY) of DSK)
              (RETURN))
          (OR (SETQ DD (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSK))
              (RETURN (RAID "[Disk debug] no disk descriptor stream")))
          (\SETFILEPTR DD \OFFSET.DISKLASTSERIAL#)
          (\BOUTS DD (LOCF (fetch (DSKOBJ DISKLASTSERIAL#) of DSK))
                 0 \NBYTES.DISKINFO)                         (* ; 
                                                "Copy interesting stuff into diskdescriptor header")
          (FORCEOUTPUT DD)
          (replace (DSKOBJ DDDIRTY) of DSK with NIL)
          (RETURN T])

(\MAKELEADERDAS
  [LAMBDA (STREAM)                                       (* ; "Edited 21-Jan-91 23:30 by jds")

    (* ;; "Makes a page map for STREAM that includes the leader vda")

    (PROG ((MAP (ARRAY 4 'WORD \FILLINDA 0)))
          (SETA MAP 0 \EOFDA)
          [SETA MAP 1 (fetch (FP FPLEADERVDA) of (fetch (ARRAYP BASE)
                                                            of (fetch (M44STREAM FID)
                                                                      of STREAM]
          (replace (M44STREAM FILEPAGEMAP) of STREAM with MAP)
          (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with -1)
          (RETURN MAP])

(DISKFREEPAGES
(LAMBDA (DSK RECOMPUTE) (* ejs%: " 7-Nov-85 16:33") (* ; "DSK ignored for now") (SELECTC \MACHINETYPE ((LIST \DANDELION \DAYBREAK) (* ; "Temporary until this become a device op") (\DFSFreeDiskPages DSK RECOMPUTE)) (\M44FREEPAGECOUNT (COND ((type? FDEV DSK) DSK) (T (\GETDEVICEFROMNAME (OR DSK (QUOTE DSK))))) NIL RECOMPUTE)))
)

(\M44FREEPAGECOUNT
(LAMBDA (DEV DIRECTORY RECOMPUTE) (* bvm%: "12-Oct-85 15:43") (PROG (CNT) (COND ((NOT (type? M44DEVICE DEV)) (\ILLEGAL.ARG DEV))) (RETURN (COND (RECOMPUTE (SETQ CNT (\COUNTDISKFREEPAGES (\OPENDISKDESCRIPTOR DEV))) (COND ((NEQ CNT (fetch (M44DEVICE DISKFREEPAGES) of DEV)) (replace (M44DEVICE DISKFREEPAGES) of DEV with CNT) (replace (M44DEVICE DDDIRTY) of DEV with T))) CNT) (T (fetch (M44DEVICE DISKFREEPAGES) of DEV))))))
)
)

(RPAQ? \M44MULTFLG T)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS UCASECHAR MACRO [(C)
                                   (COND
                                      ((ILESSP C (CHARCODE a))
                                       C)
                                      (T (IDIFFERENCE C (IDIFFERENCE (CHARCODE a)
                                                               (CHARCODE A])

(PUTPROPS UPDATEVALIDATION MACRO [(STREAM BUF)
                                          (replace VALIDATION of STREAM
                                             with (\MAKENUMBER (\GETBASE BUF 1)
                                                             (\GETBASE BUF 3])
)

(DECLARE%: EVAL@COMPILE

(ACCESSFNS M44DEVICE ((DSKOBJ (fetch DEVICEINFO of DATUM)
                                 (replace DEVICEINFO of DATUM with NEWVALUE)))
                         [TYPE? (AND (type? FDEV DATUM)
                                         (EQ (fetch OPENFILE of DATUM)
                                             '\M44OpenFile])
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \OPENFILES \M44MULTFLG \DISKNAMECASEARRAY)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS .LISP.TO.BFS. MACRO (= . ADD1))

(PUTPROPS .BFS.TO.LISP. MACRO (= . SUB1))

(PUTPROPS .DISKCASEARRAY. MACRO [NIL (fetch (ARRAYP BASE) of (\DTEST 
                                                                                   \DISKNAMECASEARRAY
                                                                                    'ARRAYP])
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ PageMapIncrement 64)

(RPAQQ \MAX.ALTO.NAME.LENGTH 39)


(CONSTANTS (PageMapIncrement 64)
       (\MAX.ALTO.NAME.LENGTH 39))
)




(* ;; "File properties")

(DECLARE%: EVAL@COMPILE

(BLOCKRECORD M44FILEPROP ((FPROPTYPE BYTE)               (* ; "Type of property")
                              (FPROPLENGTH BYTE)             (* ; "Length of entire entry in words")
                              (FPROPWORD0 WORD)              (* ; "value starts here")
                              )                              (* ; 
                                      "Overlays a piece of leader page to describe a file property")
                             )
)

(RPAQQ FPROPTYPES ((\FPROP.TYPE 136)
                       (\FPROP.PAGEMAP 137)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \FPROP.TYPE 136)

(RPAQQ \FPROP.PAGEMAP 137)


(CONSTANTS (\FPROP.TYPE 136)
       (\FPROP.PAGEMAP 137))
)

(RPAQQ FPTYPES ((\FPTYPE.UNKNOWN 0)
                    (\FPTYPE.TEXT 1)
                    (\FPTYPE.BINARY 2)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \FPTYPE.UNKNOWN 0)

(RPAQQ \FPTYPE.TEXT 1)

(RPAQQ \FPTYPE.BINARY 2)


(CONSTANTS (\FPTYPE.UNKNOWN 0)
       (\FPTYPE.TEXT 1)
       (\FPTYPE.BINARY 2))
)

(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTDEF '\M44PAGEBUFFER 'RESOURCES '(NEW (NCREATE 'VMEMPAGEP]
)
)

(/SETTOPVAL '\\M44PAGEBUFFER.GLOBALRESOURCE NIL)
)

(/SETTOPVAL '\\M44PAGEBUFFER.GLOBALRESOURCE NIL)



(* ;; "Directory enumeration")

(DEFINEQ

(\M44GENERATEFILES
(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* bvm%: "12-Oct-85 15:13") (* ;; "Returns a file-generator object that will generate AT LEAST all files in the sys-dir of FDEV whose names match PATTERN.  Clients might need to provide additional filtering.  For M44, the generate state consists of the HOSTNAME (DSK) followed by a 'search state' , a directory pointer and a character list of the sort that \SEARCHDIR1 expects.  DIRPTR is the position of the next file to be considered in the directory.") (PROG ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of FDEV)) (SORT? (EQMEMB (QUOTE SORT) OPTIONS)) (CASEBASE (.DISKCASEARRAY.)) (EXT (QUOTE *)) HOSTNAME NAME VERSION CHARLIST GENSTREAM FILTER DESIREDVERSION SEARCHSTATE HOSTPREFIX) (OR DIRSTREAM (RETURN (\NULLFILEGENERATOR))) (COND ((for TAIL on (UNPACKFILENAME.STRING PATTERN) by (CDDR TAIL) do (SELECTQ (CAR TAIL) (HOST (SETQ HOSTNAME (CADR TAIL))) (NAME (SETQ NAME (CADR TAIL))) (EXTENSION (SETQ EXT (CADR TAIL))) (VERSION (COND ((OR (EQ (NCHARS (SETQ VERSION (MKATOM (CADR TAIL)))) 0) (EQ VERSION 0)) (* ; "Newest version only") (SETQ SORT? T) (* ; "Can only get highest version by sorting") (SETQ VERSION NIL) (SETQ DESIREDVERSION T)) ((SMALLP VERSION) (* ; "An actual specific version to look for") (SETQ DESIREDVERSION VERSION)) ((NEQ VERSION (QUOTE *)) (* ; "Bogus version") (RETURN T)))) (RETURN T))) (* ; "Bad file name") (RETURN (\NULLFILEGENERATOR)))) (SETQ FILTER (DIRECTORY.MATCH.SETUP (CONCAT NAME (QUOTE %.) EXT ";*"))) (SETQ CHARLIST (for C instring (COND ((OR (EQ 0 (NCHARS EXT)) (EQ (CHCON1 EXT) (CHARCODE *))) NAME) (T (CONCAT NAME (QUOTE %.) EXT))) until (SELCHARQ (SETQ C (\GETBASEBYTE CASEBASE C)) ((%# *) (* ;; "\SEARCHDIR1 currently only checks prefixes, so we truncate at the first * or escape.  Also ignore version specifications, because of the alternative representations of version 1") T) NIL) collect C)) (COND (DESIREDPROPS (* ; "Create a scratch stream for \M44FILEINFOFN to use") (SETQ GENSTREAM (create M44STREAM)) (replace DEVICE of GENSTREAM with FDEV))) (SETQ SEARCHSTATE (create M44DIRSEARCHSTATE DIRPTR _ 0 CHARLIST _ CHARLIST)) (SETQ HOSTPREFIX (CONCAT (QUOTE {) HOSTNAME (QUOTE }))) (RETURN (COND (SORT? (* ; "Have to generate the matching files first, sort them, then enumerate") (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \M44SORTEDNEXTFILEFN) FILEINFOFN _ (FUNCTION \M44FILEINFOFN) GENFILESTATE _ (create M44GENFILESTATE DIROFD _ DIRSTREAM SEARCHSTATE _ (\M44SORTFILES DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX (LENGTH CHARLIST)) GENVERSION _ DESIREDVERSION GENSTREAM _ GENSTREAM))) (T (* ; "Order not important") (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \M44NEXTFILEFN) FILEINFOFN _ (FUNCTION \M44FILEINFOFN) GENFILESTATE _ (create M44GENFILESTATE DIROFD _ DIRSTREAM SEARCHSTATE _ SEARCHSTATE GENFILTER _ FILTER GENVERSION _ DESIREDVERSION HOSTNAME _ HOSTPREFIX GENSTREAM _ GENSTREAM)))))))
)

(\M44SORTFILES
(LAMBDA (DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH) (* bvm%: " 7-Jun-84 14:38") (SORT (bind FL while (SETQ FL (\M44GENERATENEXT DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH)) collect FL) (FUNCTION (LAMBDA (X Y) (SELECTQ (UALPHORDER (CAR X) (CAR Y)) (LESSP T) (EQUAL (IGREATERP (CADR X) (CADR Y))) NIL)))))
)

(\M44GENERATENEXT
  [LAMBDA (DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH GENFILESTATE)
                                                             (* ; "Edited 21-Jan-91 23:53 by jds")

(* ;;; "Produces the next filename from directory DIRSTREAM satisfying SEARCHSTATE and the more constrained FILTER and DESIREDVERSION, or returns NIL if no more files.  HOSTPREFIX is string to put on front, or NIL for names only.  PATTERNLENGTH is the length of the pattern in SEARCHSTATE.  GENFILESTATE is a a M44GENFILESTATE whose GENSTREAM and ENTRYSTART want to be set appropriately for \M44FILEINFOFN;  if NIL, then the value is returned for SORTFILES in the form (name version entrystart)")

    (PROG ((PATTERNHASDOT (MEMB (CHARCODE %.)
                                (fetch (M44DIRSEARCHSTATE CHARLIST) of SEARCHSTATE)))
           SAWDOT ENTRYSTART TEMP PREFIXLEN TOTALLEN THISVERSION RESULT INDEX)
      LP  (COND
             ((NOT (SETQ TEMP (\M44SEARCHDIR DIRSTREAM SEARCHSTATE)))
                                                             (* ; "Enumeration finished")
              (RETURN NIL)))
          (SETQ SAWDOT PATTERNHASDOT)
          (SETQ ENTRYSTART (IDIFFERENCE (GETFILEPTR DIRSTREAM)
                                  (IPLUS PATTERNLENGTH 13))) (* ; 
                                                       "Read all the characters from the directory")
          (SETQ TOTALLEN (IPLUS PATTERNLENGTH (SUB1 TEMP)))
          (for I from (SUB1 TEMP) to 1 by -1
             do                                          (* ; 
                                      "The SUB1 is because the last character is the undesired dot")
                   (SELCHARQ (\BIN DIRSTREAM)
                        (! [RETURN (SETQ THISVERSION (\M44READVERSION DIRSTREAM (SUB1 I])
                        (%. (SETQ SAWDOT T))
                        NIL) finally (SETQ THISVERSION 1))
          (COND
             ((AND DESIREDVERSION (NEQ THISVERSION DESIREDVERSION)
                   (NEQ DESIREDVERSION T))                   (* ; "Failure, try next")
              (GO LP)))
          [SETQ RESULT (ALLOCSTRING (IPLUS TOTALLEN (SETQ PREFIXLEN (COND
                                                                       (HOSTPREFIX (NCHARS HOSTPREFIX
                                                                                          ))
                                                                       (T 0)))
                                           (COND
                                              ((AND (EQ THISVERSION 1)
                                                    HOSTPREFIX)
                                               2)
                                              (T 0))
                                           (COND
                                              (SAWDOT 0)
                                              (T 1]
          (AND HOSTPREFIX (RPLSTRING RESULT 1 HOSTPREFIX))
          (\SETFILEPTR DIRSTREAM (IPLUS ENTRYSTART 13))      (* ; "Now read the whole name")
          (SETQ INDEX PREFIXLEN)
          (for I from TOTALLEN to 1 by -1
             do (SELCHARQ (SETQ TEMP (\BIN DIRSTREAM))
                         (%. (SETQ SAWDOT T))
                         (! (OR SAWDOT (RPLCHARCODE RESULT (add INDEX 1)
                                              (CHARCODE %.)))
                            (SETQ SAWDOT T)
                            [COND
                               (HOSTPREFIX (RPLCHARCODE RESULT (add INDEX 1)
                                                  (CHARCODE ;))
                                      (to (SUB1 I)
                                         do (RPLCHARCODE RESULT (add INDEX 1)
                                                       (COND
                                                          (GENFILESTATE (\BIN DIRSTREAM))
                                                          (T 

                                 (* ;; "Make everything a constant version for benefit of SORT.  Will replace with real thing later.  The constant version is chosen in a way that makes 2-digit versions sort in front of 1-digit versions, etc, and single-digit versions come out as ;1 to match the ;1 inserted below")

                                                             (IDIFFERENCE (CHARCODE 3)
                                                                    I]
                            (RETURN))
                         NIL)
                   (RPLCHARCODE RESULT (add INDEX 1)
                          TEMP))
          (OR SAWDOT (RPLCHARCODE RESULT (add INDEX 1)
                            (CHARCODE %.)))
          (COND
             ((AND (EQ THISVERSION 1)
                   HOSTPREFIX)
              (RPLSTRING RESULT (ADD1 INDEX)
                     ";1")))
          (COND
             ((AND FILTER (NOT (DIRECTORY.MATCH FILTER RESULT)))
              (GO LP)))
          (RETURN (COND
                     (GENFILESTATE (replace (M44GENFILESTATE ENTRYSTART) of GENFILESTATE
                                      with ENTRYSTART)
                            (replace (M44STREAM DIRINFO) of (fetch (M44GENFILESTATE
                                                                                GENSTREAM)
                                                                       of GENFILESTATE)
                               with NIL)
                            RESULT)
                     (T (LIST RESULT THISVERSION ENTRYSTART])

(\M44NEXTFILEFN
  [LAMBDA (GENFILESTATE NAMEONLY)                        (* ; "Edited 21-Jan-91 23:53 by jds")

    (* ;; "GENFILESTATE is the state information from the file-generator object created by \M44GENERATEFILES.  This function returns the next file name as a string.  Returns NIL if no files left.  It updates GENFILESTATE so that it will get the following satisfactory file on the next call to this function.  --- NAMEONLY => returns the filenames without the semi-colon and version number")

    (PROG ((DIRSTREAM (fetch (M44GENFILESTATE DIROFD) of GENFILESTATE))
           (SEARCHSTATE (fetch (M44GENFILESTATE SEARCHSTATE) of GENFILESTATE))
           (DESIREDVERSION (fetch (M44GENFILESTATE GENVERSION) of GENFILESTATE))
           (FILTER (fetch (M44GENFILESTATE GENFILTER) of GENFILESTATE))
           (HOSTPREFIX (AND (NOT NAMEONLY)
                            (fetch (M44GENFILESTATE HOSTNAME) of GENFILESTATE)))
           PATTERNLENGTH)
          (SETQ PATTERNLENGTH (LENGTH (fetch (M44DIRSEARCHSTATE CHARLIST) of SEARCHSTATE)))
          (RETURN (\M44GENERATENEXT DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX 
                         PATTERNLENGTH GENFILESTATE])

(\M44SORTEDNEXTFILEFN
  [LAMBDA (GENFILESTATE NAMEONLY)                        (* ; "Edited 21-Jan-91 23:51 by jds")
    (LET ((FILES (fetch (M44GENFILESTATE SEARCHSTATE) of GENFILESTATE))
          THISFILE THISNAME V LEN)
         (COND
            ((SETQ THISFILE (CAR FILES))                     (* ; 
                                                           "THISFILE = (name version entryStart)")
             (SETQ THISNAME (CAR THISFILE))
             (SETQ V (CADR THISFILE))

             (* ;; "need to fill in the correct version number, since the names were generated with constant version number")

             (SETQ LEN (NCHARS THISNAME))
             [COND
                [(ILESSP V 10)                               (* ; "Easy, 1-digit version")
                 (\RPLCHARCODE THISNAME LEN (PLUS V (CHARCODE 0]
                (T (SETQ V (CHCON V))
                   (for C in V as I from [SETQ LEN (ADD1 (IDIFFERENCE LEN
                                                                                (LENGTH V]
                      do (\RPLCHARCODE THISNAME I C]
             (replace (M44STREAM DIRINFO) of (fetch (M44GENFILESTATE GENSTREAM)
                                                        of GENFILESTATE) with NIL)
             (replace (M44GENFILESTATE ENTRYSTART) of GENFILESTATE with (CADDR THISFILE))
             (SETQ FILES (CDR FILES))
             (COND
                ((EQ (fetch (M44GENFILESTATE GENVERSION) of GENFILESTATE)
                     T)
                 (bind (THISNAMEONLY _ (SUBSTRING THISNAME 1 (SUB1 LEN)))
                    while (AND FILES (STRING-EQUAL (SUBSTRING (CAAR FILES)
                                                              1
                                                              (SUB1 LEN))
                                                THISNAMEONLY)) do (SETQ FILES (CDR FILES)))
                 FILES))
             (replace (M44GENFILESTATE SEARCHSTATE) of GENFILESTATE with FILES)
             THISNAME])

(\M44FILEINFOFN
  [LAMBDA (GENFILESTATE ATTRIBUTE)                       (* ; "Edited 21-Jan-91 23:51 by jds")

    (* ;; 
 "Retrieves info of file currently being enumerated.  State has a directory pointer to help us out")

    (PROG ((STREAM (fetch (M44GENFILESTATE GENSTREAM) of GENFILESTATE)))
          (OR STREAM (RETURN))
          (COND
             ((NULL (fetch (M44STREAM DIRINFO) of STREAM))
              (replace VALIDATION of STREAM with (replace (M44STREAM FILEPAGEMAP)
                                                                of STREAM with NIL))
              (replace (M44STREAM DIRINFO) of STREAM with (fetch (M44GENFILESTATE
                                                                                  ENTRYSTART)
                                                                         of GENFILESTATE))
              (replace (M44STREAM FID) of STREAM with (\M44READDIRFID
                                                                   (fetch (M44GENFILESTATE DIROFD
                                                                                     ) of 
                                                                                         GENFILESTATE
                                                                          )
                                                                   (fetch (M44GENFILESTATE 
                                                                                     ENTRYSTART)
                                                                      of GENFILESTATE)
                                                                   (fetch (M44STREAM FID)
                                                                      of STREAM)))
              (\M44ReadLeaderPage STREAM T)))
          (RETURN (\M44GetFileInfo STREAM ATTRIBUTE])
)



(* ;; "Directory lookup routines")

(DEFINEQ

(\M44PARSEFILENAME
  [LAMBDA (X RECOG DEV CREATEFLG)                        (* ; "Edited 21-Jan-91 23:47 by jds")

    (* ;; "This returns a full file specification, with all the information needed to do open, delete, etc.  A filespec is a (uname dirptr) pair, with the true version number smashed into the uname.  The dirptr is NIL if the file does not currently exist in the directory.")

    (PROG ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of DEV))
           UNAME ENDNAMEOFFSET MAYBENEW EXPLICITVERSION FIXEDVERSION UCHARS SOMEPTR TLIST PTR 
           NCHARSLEFT BESTVERSION BESTPTR VERS HMIN OLDESTP)
          [COND
             ([NULL (SETQ UNAME (\M44UNPACKFILENAME X DEV (SELECTQ RECOG
                                                                  ((NEW OLD/NEW) 
                                                             (* ; 
                 "We might create a new file here, so tell unpack to save the original characters.")
                                                                       (SETQ MAYBENEW T))
                                                                  NIL]
                                                             (* ; "BAD FILE NAME")
              (RETURN (create FILESPEC
                             UNAME _ NIL]

     (* ;; "Name parsed ok, get ready to search directory for it.")

          (SETQ UCHARS (fetch (UNAME UCASECHARS) of UNAME))
          (SETQ ENDNAMEOFFSET (+ 13 (LENGTH UCHARS)))        (* ; "ENDNAMEOFFSET is length of name we're searching for plus fixed overhead (header word, FID, name length byte)")
          [COND
             (CREATEFLG                                      (* ; "Want to look for a hole, in case we need to create the file.  The 6 is to allow for the maximum number of chars in a version number")
                    (SETQ HMIN (FOLDLO (+ ENDNAMEOFFSET 6)
                                      BYTESPERWORD]
          (SETQ TLIST (CONS 0 UCHARS))                       (* ; 
                                    "Pair of dirptr & chars used to communicate with \M44SEARCHDIR")
          (if (AND (FIXP (SETQ EXPLICITVERSION (fetch (UNAME VERSION) of UNAME)))
                       (NEQ EXPLICITVERSION 0))
              then                                       (* ; 
        "If caller gave a real explicit version, then if we find that version, we know we're done.")
                    (SETQ FIXEDVERSION EXPLICITVERSION))
          (SETQ OLDESTP (EQ (OR EXPLICITVERSION RECOG)
                            'OLDEST))
      SEARCHLP
          (COND
             ((NULL (SETQ NCHARSLEFT (\M44SEARCHDIR DIRSTREAM TLIST HMIN)))
                                                             (* ; "No more prefix matches found")
              (GO DONE)))
          (SETQ PTR (\GETFILEPTR DIRSTREAM))                 (* ; "Note current position")
          (COND
             ((EQ NCHARSLEFT 1)                              (* ; 
                        "No version, just the final dot remains, so we must have matched version 1")
              (SETQ VERS 1))
             ((NEQ (\BIN DIRSTREAM)
                   (CHARCODE !))                             (* ; 
                                                    "More chars follow before version, so no match")
              (GO NEXT))
             ([NULL (SETQ VERS (\M44READVERSION DIRSTREAM (- NCHARSLEFT 2]
              (GO NEXT)))

     (* ;; "Name matches.  VERS is the version number.  Is it better than we've seen?  Accumulate extreme vers,ptr in BESTVERSION,BESTPTR.")

          (SETQ PTR (- PTR ENDNAMEOFFSET))                   (* ; 
                                                           "Beginning of the directory entry")
          (COND
             [FIXEDVERSION                                   (* ; "Version must match")
                    (SETQ BESTPTR PTR)                       (* ; 
                                        "Always note a pointer, for benefit of getting case right.")
                    (COND
                       ((EQ VERS FIXEDVERSION)               (* ; "The one we've been looking for")
                        (SETQ BESTVERSION VERS)
                        (GO DONE]
             ((OR (NULL BESTVERSION)
                  (if OLDESTP
                      then (< VERS BESTVERSION)
                    else (> VERS BESTVERSION)))          (* ; "More extreme than the last one")
              (SETQ BESTVERSION VERS)
              (SETQ BESTPTR PTR)))
      NEXT
          (COND
             ((AND HMIN (fetch (M44STREAM DIRHOLEPTR) of DIRSTREAM))
                                                             (* ; 
                                                           "Stop looking for a hole if found one")
              (SETQ HMIN NIL)))
          (GO SEARCHLP)
      DONE
          

     (* ;; "At this point, BESTVERSION is the version, if any, that best matches RECOG or funny version spec in UNAME, i.e., it is the oldest or newest version.  BESTPTR is the corresponding directory pointer.  In the case where an explicit version was requested but not found, BESTPTR is the directory pointer of SOME version.  So now we need to bump the version up for RECOG = NEW, and maybe adjust the characters.")

          (SETQ SOMEPTR BESTPTR)                             (* ; 
                                        "Save dir pointer for getting at true chars for new files.")
          (if BESTVERSION
              then                                       (* ; "Found one")
                    (if (if EXPLICITVERSION
                                then                     (* ; "Ignore funny version N when asking for %"OLD%" recognition--don't want FOO;N to mean next highest version, since that's a lie. e.g., it's not infilep.")
                                      (AND (EQ EXPLICITVERSION 'NEW)
                                           MAYBENEW)
                              else (EQ RECOG 'NEW))
                        then (add BESTVERSION 1)     (* ; 
                                     "Bump version, clear directory pointer (since we're creating)")
                              (SETQ BESTPTR NIL))
            elseif MAYBENEW
              then                                       (* ; 
                                     "Specified file doesn't exist, but we're willing to create it")
                    (SETQ BESTVERSION (OR FIXEDVERSION 1))
                    (SETQ BESTPTR NIL))
          (RETURN (if BESTVERSION
                      then                               (* ; "Success")
                            (if (NULL BESTPTR)
                                then                     (* ; 
                                     "New file.  Get the case right if some other version existed.")
                                      (if SOMEPTR
                                          then (replace (UNAME ORIGCHARS) of UNAME
                                                      with (\M44READDIRNAME DIRSTREAM SOMEPTR
                                                                      )))
                              elseif (fetch (UNAME ORIGCHARS) of UNAME)
                                then                     (* ; 
  "New recog but existing file--happens when overwriting.  Still want to get the characters right.")
                                      (replace (UNAME ORIGCHARS) of UNAME
                                         with (\M44READDIRNAME DIRSTREAM BESTPTR)))
                            (replace (UNAME VERSION) of UNAME with BESTVERSION)
                            (create FILESPEC
                                   UNAME _ UNAME
                                   FSDIRPTR _ BESTPTR])

(\FINDDIRHOLE
  [LAMBDA (NWORDS DIRSTREAM)                             (* ; "Edited 21-Jan-91 23:37 by jds")

    (* ;; "Returns the byte address of a directory hole of size NWORDS.  The directory file is positioned just after the 2-byte length field of the hole.")

    (PROG ((HINT (fetch (M44STREAM DIRHOLEPTR) of DIRSTREAM))
           PTR ENTRYLENGTH C)
          (SETQ PTR (OR HINT 0))
      NEXT
          (\SETFILEPTR DIRSTREAM PTR)
          (COND
             ((\EOFP DIRSTREAM)
              (if (AND HINT (> HINT 0))
                  then                                   (* ; 
                                                           "Hint failed, so try from the start.")
                        (SETQ HINT NIL)
                        (SETQ PTR 0)
                        (GO NEXT)
                else (GO END)))
             ((AND (>= (SETQ ENTRYLENGTH (+ (LLSH (LOGAND (SETQ C (\BIN DIRSTREAM))
                                                         3)
                                                  8)
                                            (\BIN DIRSTREAM)))
                       NWORDS)
                   (< C 4))

              (* ;; "First 6 bits is entry type, next 10 bits are length of entry in words.  Free entries have type zero.  Thus C < 4 implies this is free entry.")

              (\SETFILEPTR DIRSTREAM PTR)                    (* ; "Hole is large enough")
              [COND
                 ((> ENTRYLENGTH NWORDS)                     (* ; 
                "Too large, so split hole into 2 parts.  We'll return the second half of the hole.")
                  (\WOUT DIRSTREAM (SETQ ENTRYLENGTH (- ENTRYLENGTH NWORDS)))
                  (\SETFILEPTR DIRSTREAM (add PTR (UNFOLD ENTRYLENGTH BYTESPERWORD]
              (GO END)))
          (add PTR (UNFOLD ENTRYLENGTH BYTESPERWORD))
          (GO NEXT)
      END (\WOUT DIRSTREAM NWORDS)
          (RETURN PTR])

(\M44PACKFILENAME
(LAMBDA (UNAME DIRPTR DIRSTREAM) (* ; "Edited 12-Jan-88 12:01 by bvm") (* ;; "Produces a Lisp style file-name of the form 'name.[ext];ver'") (LET* ((CHARS (OR (AND (NULL *UPPER-CASE-FILE-NAMES*) (OR (fetch (UNAME ORIGCHARS) of UNAME) (if DIRPTR then (* ; "Get the exact name out of the directory") (\M44READDIRNAME DIRSTREAM DIRPTR)))) (fetch (UNAME UCASECHARS) of UNAME))) (NAME (CONCAT (QUOTE {) (fetch (UNAME PARTNAME) of UNAME) (QUOTE }) (CONCATCODES CHARS) (COND ((MEMB (CHARCODE %.) CHARS) ";") (T ".;")) (fetch (UNAME VERSION) of UNAME)))) (if *UPPER-CASE-FILE-NAMES* then (MKATOM NAME) else NAME)))
)

(\M44READVERSION
(LAMBDA (DIRSTREAM MAXCHARS) (* bvm%: " 7-Jun-84 11:38") (to MAXCHARS bind (VERSION _ 0) C do (SETQ C (\BIN DIRSTREAM)) (COND ((AND (IGEQ C (CHARCODE 0)) (ILEQ C (CHARCODE 9))) (SETQ VERSION (IPLUS (ITIMES VERSION 10) (IDIFFERENCE C (CHARCODE 0))))) (T (* ;; "A non-numeric after a ! means that it wasn't the version marker.  This is permissible by alto file spec") (RETURN))) finally (RETURN VERSION)))
)

(\OPENDISKDESCRIPTOR
  [LAMBDA (DEV)                                          (* ; "Edited 21-Jan-91 23:43 by jds")

    (* ;; "Opens and returns a stream on the disk descriptor file for DEV")

    [COND
       ((NOT (type? FDEV DEV))
        (SETQ DEV (\GETDEVICEFROMNAME (fetch (DSKOBJ DISKDEVICENAME) of DEV]
    (OR (fetch (M44DEVICE DDVALID) of DEV)
        (PROG ((OLDD (fetch (M44DEVICE DISKDESCRIPTOROFD) of DEV))
               STREAM)
              (COND
                 (OLDD (FORGETPAGES OLDD)))
              [SETQ STREAM (COND
                              ((EQ (fetch (M44DEVICE DSKOBJ) of DEV)
                                   \MAINDISK)
                               (\M44OPENFILEFROMFP DEV "DISKDESCRIPTOR.;1" 'BOTH (
                                                                                 \CREATE.FID.FOR.DD
                                                                                      DEV)))
                              (T (\OPENFILE (CONCAT "{" (fetch (FDEV DEVICENAME) of DEV)
                                                   "}" "DISKDESCRIPTOR.;1")
                                        'BOTH]
              (replace USERVISIBLE of STREAM with NIL)
              (replace (M44DEVICE DISKDESCRIPTOROFD) of DEV with STREAM)
              (replace MAXBUFFERS of STREAM with (ADD1 (fetch EPAGE of STREAM)))
                                                             (* ; 
                 "Prepare to buffer the whole file, so that we don't get in trouble under \NEWPAGE")
              (for I from 0 to (fetch EPAGE of STREAM)
                 do (\MAPPAGE I STREAM))                 (* ; 
                                          "Ought to define a \MAPPAGES to do that more efficiently")
              (replace ENDOFSTREAMOP of STREAM with (FUNCTION NILL))
              (replace (M44DEVICE DDVALID) of DEV with T)))
    (fetch (M44DEVICE DISKDESCRIPTOROFD) of DEV])

(\M44READDIRFID
  [LAMBDA (DIRSTREAM DIRPTR FID)                         (* ; "Edited 21-Jan-91 23:39 by jds")

    (* ;; "Read the 5-word FID from the directory into FID (or create a new one if FID is nil).  Return the new FID.")

    (\SETFILEPTR DIRSTREAM (+ DIRPTR 2))
    (\BINS DIRSTREAM [fetch (FID FIDBLOCK) of (OR FID (SETQ FID (create FID]
           0
           (UNFOLD 5 BYTESPERWORD))
    FID])

(\M44READDIRNAME
(LAMBDA (DIRSTREAM DIRPTR) (* ; "Edited 11-Jan-88 14:39 by bvm") (* ;; "Read the exact file name, sans version number, from directory stream as a list of char codes.") (* ;; "Format of a directory entry is --- Type&WordLength (1 word), FP (5 words), Name as a BcplString") (SETFILEPTR DIRSTREAM (+ DIRPTR 12)) (to (SUB1 (BIN DIRSTREAM)) bind CH until (EQ (SETQ CH (BIN DIRSTREAM)) (CHARCODE !)) collect CH))
)

(\M44SEARCHDIR
  [LAMBDA (STREAM TLIST HMIN)                            (* ; "Edited 21-Jan-91 23:37 by jds")

    (* ;; "TLIST is a list of the form (POS . NAMECHARS), where POS at entry is a fileptr in the directory file at which to start searching and NAMECHARS is like the characters pairs of a uname.  Finds next directory entry for which NAMECHARS is a prefix of the filename.  Returns NIL if no entry found, else the length of the remaining chars in the entry.  Leaves the directory positioned after the char matching the last char of NAMECHARS --- STREAM is the ofd of the directory file --- At exit, TLIST is smashed so that POS is the fileptr just beyond the found entry.  --- if HMIN~=NIL, sets STREAM's DIRHOLEPTR to NIL or the fileptr of the first hole of at least HMIN words.")

    (PROG ((CASEBASE (.DISKCASEARRAY.))
           (NEXT (CAR TLIST))
           (NAMECHARS (CDR TLIST))
           THISNAMELENGTH TARGETLENGTH PTR L TYP ENTRYLENGTH)
          (COND
             (HMIN (replace (M44STREAM DIRHOLEPTR) of STREAM with NIL)))
          (SETQ TARGETLENGTH (LENGTH NAMECHARS))
      NEXT
          (\SETFILEPTR STREAM (SETQ PTR NEXT))
          (COND
             ((\EOFP STREAM)
              (RETURN)))

     (* ;; "Format of a directory entry is --- Type (0 = hole, 1 = file), 6 bits --- Length of entry in words, 10 bits --- FP 5 words --- Name as a BcplString")

          (SETQ TYP (\BIN STREAM))
          (SETQ ENTRYLENGTH (IPLUS (LLSH (LOGAND TYP 3)
                                         8)
                                   (\BIN STREAM)))
          (SETQ NEXT (IPLUS (UNFOLD ENTRYLENGTH BYTESPERWORD)
                            PTR))
          (COND
             ((NEQ (LRSH TYP 2)
                   1)                                        (* ; "Not a file")
              (COND
                 ((AND HMIN (NOT (IGREATERP HMIN ENTRYLENGTH)))
                  (replace (M44STREAM DIRHOLEPTR) of STREAM with PTR)
                  (SETQ HMIN NIL)))
              (GO NEXT)))
          (\SETFILEPTR STREAM (IPLUS PTR 12))
          (COND
             ((ILESSP (SETQ THISNAMELENGTH (\BIN STREAM))
                     TARGETLENGTH)
              (GO NEXT)))
          (SETQ L NAMECHARS)
      READ
          (COND
             ((NULL L)                                       (* ; 
                                      "Exhausted the pattern before finding a mismatch, so take it")
              (RPLACA TLIST NEXT)
              (RETURN (IDIFFERENCE THISNAMELENGTH TARGETLENGTH)))
             ((EQ (\GETBASEBYTE CASEBASE (\BIN STREAM))
                  (CAR L))
              (SETQ L (CDR L))
              (GO READ))
             (T (GO NEXT])

(\M44UNPACKFILENAME
  [LAMBDA (NAME DEV CREATEFLG)                           (* ; "Edited 21-Jan-91 23:47 by jds")

    (* ;; "Unpacks file name into a UNAME whose VERSION is the version indicator (either a positive integer or one of OLD, OLDEST, NEW);  PARTNAME is the name of DEV.  UCASECHARS is a list of uppercase charcodes from the name.  If CREATEFLG is true, also sets ORIGCHARS to be list of original char codes, for sake of setting real file name")

    (PROG ((CASEBASE (.DISKCASEARRAY.))
           (NC 0)
           J C UPC END ORIGEND VERSION RESULT DOTPREV ORIGDOTPREV EXCESS TAIL)
          (COND
             ((OR (NOT NAME)
                  (EQ NAME T)
                  (NOT (OR (LITATOM NAME)
                           (STRINGP NAME)))
                  (NEQ (NTHCHARCODE NAME 1)
                       (CHARCODE {))
                  (NOT (SETQ J (STRPOS "}" NAME 5)))
                  (EQ (NTHCHARCODE NAME (add J 1))
                      (CHARCODE <)))

              (* ;; "Name is not a non-null string/atom, or doesn't have a host on front, or { is mismatched, or there's a directory.  There used to be some junk in here about passing back a different value if the name had a directory than if it was otherwise malformed, but we really have no use for that.")

              (RETURN NIL)))
          [SETQ END (fetch (UNAME UCASECHARHEAD) of (SETQ RESULT (create UNAME
                                                                                PARTNAME _
                                                                                (fetch DEVICENAME
                                                                                   of DEV]
                                                             (* ; 
                                                        "End is the cell whose CDR can be smashed.")
          (SETQ ORIGEND (fetch (UNAME ORIGCHARHEAD) of RESULT))
      COLLECTNAME
          (COND
             ((NOT (SETQ C (NTHCHARCODE NAME J)))            (* ; "End of name")
              (GO RET))
             ((EQ (SETQ UPC (\GETBASEBYTE CASEBASE C))
                  0)                                         (* ; "Illegal char")
              (GO ERR))
             (T [RPLACD END (SETQ END (LIST (SELCHARQ UPC
                                                 (; (GO SEMI))
                                                 ((%# *)     (* ; "Wildcards not allowed")
                                                      (GO ERR))
                                                 (%.         (* ; "Omit trailing dots")
                                                     (PROG1 (SELCHARQ (NTHCHARCODE NAME (ADD1 J))
                                                                 (NIL (GO RET))
                                                                 ((; !) 
                                                                      (add J 1)
                                                                      (GO SEMI))
                                                                 UPC)
                                                         (SETQ DOTPREV END)
                                                             (* ; 
                                                   "Save tail position here in case name gets long")
                                                         (AND CREATEFLG (SETQ ORIGDOTPREV ORIGEND))))
                                                 UPC]
                [COND
                   (CREATEFLG                                (* ; "Save orig chars as well")
                          (RPLACD ORIGEND (SETQ ORIGEND (LIST C]
                (add J 1)
                (add NC 1)
                (GO COLLECTNAME)))
      SEMI
          

     (* ;; "Parsing the stuff after the semicolon;  we only accept version, though we do accept the funny symbolic versions H, L and N.")

          (COND
             ([NULL (SETQ C (NTHCHARCODE NAME (add J 1]
              (GO RET))
             ((EQ (SETQ C (\GETBASEBYTE CASEBASE C))
                  0)                                         (* ; "Illegal char")
              (GO ERR)))
          (SELCHARQ C
               (H (SETQQ VERSION OLD))
               (L (SETQQ VERSION OLDEST))
               (N (SETQQ VERSION NEW))
               (GO COLLECTVERSION))
          (if (EQ J (NCHARS NAME))
              then                                       (* ; "Done")
                    (GO RET)
            else                                         (* ; "Malformed name")
                  (GO ERR))
      COLLECTVERSION
          (SETQ VERSION 0)
          [while (AND C (BETWEEN C (CHARCODE 0)
                                   (CHARCODE 9))) do [SETQ VERSION (+ (TIMES VERSION 10)
                                                                          (- C (CHARCODE 0]
                                                        (SETQ C (NTHCHARCODE NAME (add J 1]
          (COND
             ((EQ VERSION 0)
              (SETQQ VERSION OLD))
             ((IGREATERP VERSION 65535)
              (GO ERR)))
          (if (NULL C)
              then                                       (* ; "end of name ok")
                    (GO RET))
      ERR                                                    (* ; "BAD FILE NAME")
          (RETURN NIL)
      RET (replace (UNAME VERSION) of RESULT with VERSION)
          [if (> (SETQ EXCESS (- NC (- \MAX.ALTO.NAME.LENGTH 7)))
                     0)
              then

              (* ;; "Hmm, is name too long?  7 counts for a possible !, 5 version chars and the final dot.  This is unnecessarily restrictive for names with shorter versions, but it would get quite untidy if you let version 9 squeak in and then complain or shorten on 10.  So best to shorten now.  We prefer to leave the extension intact, since that can convey info, and shorten the name.")

              [if DOTPREV
                  then (SETQ DOTPREV (CDR DOTPREV))      (* ; "Now (CAR DOTPREV) is the period")
                        (SETQ ORIGDOTPREV (CDR ORIGDOTPREV))
                        (if (CDR (SETQ TAIL (CL:NTHCDR 10 DOTPREV)))
                            then                         (* ; 
             "Extension longer than 10 chars (this allows, e.g., INTERPRESS), so let's shorten it.")
                                  (if (<= (SETQ NC (LENGTH (CDR TAIL)))
                                              EXCESS)
                                      then               (* ; "Chop off the entire excess")
                                            (RPLACD TAIL NIL)
                                            (if CREATEFLG
                                                then (RPLACD (CL:NTHCDR 10 ORIGDOTPREV)
                                                                NIL))
                                            (SETQ EXCESS (- EXCESS NC))
                                    else                 (* ; "only have to get rid of some")
                                          (RPLACD (CL:NTHCDR (- NC EXCESS)
                                                         TAIL)
                                                 NIL)
                                          (if CREATEFLG
                                              then (RPLACD (CL:NTHCDR (+ 10 (- NC EXCESS))
                                                                      ORIGDOTPREV)
                                                              NIL))
                                          (SETQ EXCESS 0]
              (if (> EXCESS 0)
                  then                                   (* ; "Chop away at name")
                        (RPLACD (NLEFT (fetch (UNAME UCASECHARS) of RESULT)
                                       (ADD1 EXCESS)
                                       DOTPREV)
                               DOTPREV)
                        (if CREATEFLG
                            then (RPLACD (NLEFT (fetch (UNAME ORIGCHARS) of RESULT)
                                                    (ADD1 EXCESS)
                                                    ORIGDOTPREV)
                                            ORIGDOTPREV]
          (RETURN RESULT])
)

(RPAQQ \FILENAMECHARSLST (36 43 45 46))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \FILENAMECHARSLST)
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD UNAME (VERSION . UCASECHARHEAD)
                  (RECORD UCASECHARHEAD (ORIGCHARHEAD . UCASECHARS)
                         (RECORD ORIGCHARHEAD (PARTNAME . ORIGCHARS))))

(RECORD FILESPEC (UNAME FSDIRPTR)
                     [ACCESSFNS FILESPEC ((PNAME (\M44PACKFILENAME (fetch UNAME of DATUM])

(RECORD M44GENFILESTATE (DIROFD SEARCHSTATE GENFILTER GENVERSION HOSTNAME GENSTREAM ENTRYSTART))

(RECORD M44DIRSEARCHSTATE (DIRPTR . CHARLIST))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS BETWEEN MACRO (OPENLAMBDA (V LO HI)
                                  (AND (IGEQ V LO)
                                       (ILEQ V HI))))
)
)
(DEFINEQ

(\CREATE.FID.FOR.DD
  [LAMBDA (FDEV)                                         (* ; "Edited 21-Jan-91 23:39 by jds")

    (* ;; "Creates a FID for the file DISKDESCRIPTOR on FDEV, which must be the default disk partition's device")

    (PROG ((FID (create FID)))

     (* ;; "Currently \SYSDISK has a copy of the diskdescriptor fp inside it, as looked up by alto at beginning of world, so be lazy and use that")

          (\BLT (fetch (FID FIDBLOCK) of FID)
                (LOCF (fetch (M44DEVICE DSKDDBLK) of FDEV))
                \LENFP)
          (RETURN FID])

(\OPENDISK
  [LAMBDA (PARTNUM FDEV)                                 (* ; "Edited 21-Jan-91 23:32 by jds")
    (PROG (DSK DD)
          (OR (\TESTPARTITION PARTNUM)
              (RETURN))
          (SETQ DSK (create DSKOBJ))
          (\LOCKWORDS DSK \NWORDS.DSKOBJ)
          (replace (DSKOBJ DSKPARTITION) of DSK with PARTNUM)
          (replace (DSKOBJ ddPOINTER) of DSK with (LOCF (fetch (DSKOBJ ddLASTSERIAL#)
                                                                       of DSK)))
          (replace (DSKOBJ NDISKS) of DSK with 2)
          (replace (DSKOBJ NTRACKS) of DSK with 406)
          (replace (DSKOBJ NHEADS) of DSK with 2)
          (replace (DSKOBJ NSECTORS) of DSK with 14)
          (replace (DSKOBJ RETRYCOUNT) of DSK with 8)
          (replace (DSKOBJ CBQUEUE) of DSK with (fetch (DSKOBJ CBQUEUE) of 
                                                                                            \MAINDISK
                                                                   ))
                                                             (* ; "Really should have our own")
          (RETURN (\OPENDISKDEVICE PARTNUM DSK FDEV])

(\OPENDISKDEVICE
  [LAMBDA (PARTITION DSKOBJ FDEV)                        (* ; "Edited 21-Jan-91 23:43 by jds")
    (DECLARE (GLOBALVARS \MAINDISK))                     (* ; 
                                            "Creates the model 44 DSK device and opens its SYSDIR.")
    (PROG ([NAME (PACK* 'DSK (OR PARTITION (DISKPARTITION]
           FDEV)
          [OR FDEV (SETQ FDEV (\MAKE.PMAP.DEVICE (create FDEV
                                                        DEVICENAME _ NAME
                                                        NODIRECTORIES _ T
                                                        CLOSEFILE _ (FUNCTION \M44CloseFile)
                                                        DELETEFILE _ (FUNCTION \M44DeleteFile)
                                                        GETFILEINFO _ (FUNCTION \M44GetFileInfo)
                                                        GETFILENAME _ (FUNCTION \M44GetFileName)
                                                        OPENFILE _ (FUNCTION \M44OpenFile)
                                                        READPAGES _ (FUNCTION \M44ReadPages)
                                                        SETFILEINFO _ (FUNCTION \M44SetFileInfo)
                                                        TRUNCATEFILE _ (FUNCTION \M44TruncateFile)
                                                        WRITEPAGES _ (FUNCTION \M44WritePages)
                                                        REOPENFILE _ (FUNCTION \M44OpenFile)
                                                        GENERATEFILES _ (FUNCTION \M44GENERATEFILES)
                                                        EVENTFN _ (FUNCTION \M44EVENTFN)
                                                        DIRECTORYNAMEP _ [FUNCTION (LAMBDA (NAME)
                                                             (* ; 
                                                       "Assume host is OK, check that no directory")
                                                                                     (EQ (NTHCHARCODE
                                                                                          NAME -1)
                                                                                         (CHARCODE
                                                                                          }]
                                                        HOSTNAMEP _ (FUNCTION NILL)
                                                        FREEPAGECOUNT _ (FUNCTION \M44FREEPAGECOUNT)
                                                        OPENP _ (FUNCTION \GENERIC.OPENP)
                                                        REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM)
                                                        UNREGISTERFILE _ (FUNCTION 
                                                                          \GENERIC-UNREGISTER-STREAM]
          (replace (M44DEVICE DSKOBJ) of FDEV with (OR DSKOBJ (SETQ DSKOBJ \MAINDISK)))
          (replace (DSKOBJ DISKDEVICENAME) of DSKOBJ with NAME)
          (RETURN (RESETLST
                      (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (DEV)
                                                       (COND
                                                          ((NOT (fetch (M44DEVICE DSKPASSWORDOK)
                                                                   of DEV))
                                                             (* ; 
                                                           "Oops, it didn't work, take it away")
                                                           (\REMOVEDEVICE DEV]
                                           FDEV))
                      (\DEFINEDEVICE NAME FDEV)              (* ; 
                        "have to define it tentatively first so that \OPENDISKDESCRIPTOR will work")
                      (COND
                         ((\OPENDIR FDEV)
                          (COND
                             ((NULL PARTITION)               (* ; "this is also the default disk")
                              (\DEFINEDEVICE 'DSK FDEV)))
                          FDEV)))])

(\OPENDIR
(LAMBDA (FDEV) (* bvm%: " 6-APR-83 12:16") (* ;; "Opens the model44 directory on the current partition") (PROG ((PART (fetch (M44DEVICE DSKPARTITION) of FDEV)) STREAM DD) (replace (M44DEVICE DSKPASSWORDOK) of FDEV with NIL) (COND ((AND (NEQ PART 0) (NOT (\TESTPARTITION PART))) (replace (M44DEVICE SYSDIROFD) of FDEV with NIL) (RETURN))) (SETQ STREAM (\M44OPENFILEFROMFP FDEV "SYSDIR.;1" (QUOTE BOTH) (create FID W0 _ 32768 W1 _ 100 W2 _ 1 W3 _ 0 W4 _ 1))) (* ; "{DSK}SYSDIR.;1 always has sn 100, leader page on virtual page 1") (replace MAXBUFFERS of STREAM with (IMAX 64 (ADD1 (fetch EPAGE of STREAM)))) (* ; "Enough buffers so that directory is effectively always in core") (replace (M44DEVICE SYSDIROFD) of FDEV with STREAM) (COND ((NEQ PART 0) (SETQ DD (\OPENDISKDESCRIPTOR FDEV)) (\SETFILEPTR DD \OFFSET.DISKLASTSERIAL#) (\BINS DD (LOCF (fetch (M44DEVICE DISKLASTSERIAL#) of FDEV)) 0 \NBYTES.DISKINFO) (add (fetch (M44DEVICE DISKLASTSERIAL#) of FDEV) 3) (* ; "Try to avoid collisions") (COND ((NOT (\M44CHECKPASSWORD FDEV)) (replace (M44DEVICE SYSDIROFD) of FDEV with NIL) (RETURN))))) (replace (M44DEVICE DSKPASSWORDOK) of FDEV with T) (RETURN STREAM)))
)

(\M44CHECKPASSWORD
(LAMBDA (DEV) (* bvm%: "11-Jun-86 12:20") (PROG ((STREAM (\OPENFILE (PACK* (QUOTE {) (fetch (FDEV DEVICENAME) of DEV) "}SYS.BOOT;1") (QUOTE INPUT) (QUOTE OLD))) PASSVECTOR BUF PASSINFO ASKEDONCE NAME N) (COND ((NULL STREAM) (RETURN T))) (SETQ PASSVECTOR (\ALLOCBLOCK (FOLDHI \NWORDS.BCPLPASSWORD WORDSPERCELL))) (SETFILEPTR STREAM \OFFSET.BCPLPASSWORD) (\BINS STREAM PASSVECTOR 0 (UNFOLD \NWORDS.BCPLPASSWORD BYTESPERWORD)) (COND ((EQ (\GETBASE PASSVECTOR 0) 0) (* ; "No password") (\CLOSEFILE STREAM) (RETURN T))) (SETFILEPTR STREAM \OFFSET.BCPLUSERNAME) (SETQ NAME (ALLOCSTRING (SETQ N (\BIN STREAM)))) (* ; "Read in a bcpl string which is the username installed on the disk") (\BINS STREAM (fetch (STRINGP BASE) of NAME) 0 N) (\CLOSEFILE STREAM) (SETQ NAME (MKATOM NAME)) LP (SETQ PASSINFO (\INTERNAL/GETPASSWORD (fetch (FDEV DEVICENAME) of DEV) ASKEDONCE NIL NIL NAME)) (COND ((NULL PASSINFO) (RETURN NIL))) (COND ((UNINTERRUPTABLY (SETQ BUF (\GETPACKETBUFFER)) (* ; "HORRIBLE CHEAP TRICK to get some emulator space") (\BLT (\ADDBASE BUF 64) PASSVECTOR \NWORDS.BCPLPASSWORD) (SetBcplString (\ADDBASE BUF (IPLUS 64 \NWORDS.BCPLPASSWORD)) (\DECRYPT.PWD (CDR PASSINFO))) (\CHECKBCPLPASSWORD (\ADDBASE BUF (IPLUS 64 \NWORDS.BCPLPASSWORD)) (\ADDBASE BUF 64))) (RETURN T)) (T (SETQ ASKEDONCE T) (GO LP)))))
)

(\M44HOSTNAMEP
(LAMBDA (NAME DEV) (* bvm%: "20-Nov-84 16:06") (PROG (PARTNUM) (RETURN (COND ((EQ NAME (QUOTE DSK)) (\OPENDISKDEVICE)) ((AND (STRPOS (QUOTE DSK) NAME 1 NIL T) (SETQ PARTNUM (FIXP (SUBATOM NAME 4))) (\TESTPARTITION PARTNUM)) (COND ((EQ PARTNUM (DISKPARTITION)) (RETURN (\GETDEVICEFROMNAME (QUOTE DSK)))) (T (\OPENDISK PARTNUM))))))))
)
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ \OFFSET.BCPLUSERNAME 512)

(RPAQQ \OFFSET.BCPLPASSWORD 768)

(RPAQQ \NWORDS.BCPLPASSWORD 9)


(CONSTANTS \OFFSET.BCPLUSERNAME \OFFSET.BCPLPASSWORD \NWORDS.BCPLPASSWORD)
)
)



(* ;; "SYSOUT etc.")

(DEFINEQ

(\COPYSYS1
(LAMBDA (STREAM LASTPAGE) (* ; "Edited 21-Aug-88 13:54 by bvm") (COND ((AND (type? M44DEVICE (fetch DEVICE of STREAM)) (EQ (fetch DEVICENAME of (fetch DEVICE of STREAM)) (QUOTE DSK))) (ERROR "Sysout to Dorado login partition no longer supported."))) (PROG ((ACTONVMEMFN \VMEMACCESSFN) (PAGEMAPPED (fetch PAGEMAPPED of (fetch DEVICE of STREAM))) (NBUFS (SUB1 \#EMUBUFFERS)) (BUFBASE \EMUBUFFERS) (FIRSTPAGE 2) (CURSORBAR \EM.CURSORBITMAP) (CURSORMASK (LLSH 1 (SUB1 BITSPERWORD))) (DOMINOPAGE (fetch LastDominoFilePage of \InterfacePage)) (DAYBREAKP (EQ \MACHINETYPE \DAYBREAK)) CURSORINC CURSORNEXT NPAGES BUFFERS) (* ;; "Strategy is to copy from the vmem file to STREAM --- The vmem file is read with \ACTONVMEMFILE to finesse the differences among machines.  As buffers we use the set of pre-allocated swap buffers, reducing the number available for swapping to a bare minimum of one.  If STREAM is pagemapped, we take advantage of knowledge of pagemapped streams to write these buffers directly to the destination stream, which saves the copying that would occur if we just generically used \BOUTS for all streams.  In the case of Mod44 DSK, this also lets us use more buffers at a time, because DSK can write directly from the buffers we use for reading the vmem, rather than copying into its own buffers") (RESETSAVE \#SWAPBUFFERS 1) (* ; "Reduce us to one swap buffer, so we can use the rest for copying the vmem") (RESETSAVE \EMUSWAPBUFFERS (\ADDBASE BUFBASE (UNFOLD NBUFS WORDSPERPAGE))) (RESETSAVE \#DISKBUFFERS (COND ((type? M44DEVICE (fetch DEVICE of STREAM)) (* ; "DSK code needs 1 extra buffer beyond the ones we give to \WRITEPAGES") (SETQ NBUFS (SUB1 NBUFS)) (SETQ BUFBASE (\ADDBASE BUFBASE WORDSPERPAGE)) 1) (T 0))) (SETQ BUFFERS (to NBUFS as (BUF _ BUFBASE) by (\ADDBASE BUF WORDSPERPAGE) collect BUF)) (SETQ CURSORINC (SETQ CURSORNEXT (FOLDLO LASTPAGE (ITIMES 16 16)))) (* ; "How often to do something to the cursor") (COND ((EQ DOMINOPAGE 0) (* ; "First page to write is the ISF map page, which should be blank in a sysout") (\CLEARWORDS BUFBASE WORDSPERPAGE)) (T (CL:FUNCALL ACTONVMEMFN DOMINOPAGE BUFBASE 1))) (COND (PAGEMAPPED (replace EPAGE of STREAM with LASTPAGE) (* ; "Set up end of file correctly.  LASTPAGE is last alto page (full), which is last Lisp page plus 1") (replace EOFFSET of STREAM with 0) (\WRITEPAGES STREAM 0 (CAR BUFFERS))) (T (\BOUTS STREAM (CAR BUFFERS) 0 BYTESPERPAGE))) (while (<= FIRSTPAGE LASTPAGE) do (COND ((>= FIRSTPAGE CURSORNEXT) (* ; "Gradually complement the cursor") (\PUTBASE CURSORBAR 0 (LOGXOR (\GETBASE CURSORBAR 0) CURSORMASK)) (COND (DAYBREAKP (\DoveDisplay.SetCursorShape))) (add CURSORNEXT CURSORINC) (COND ((EQ (SETQ CURSORMASK (LRSH CURSORMASK 1)) 0) (SETQ CURSORBAR (\ADDBASE CURSORBAR 1)) (SETQ CURSORMASK (LLSH 1 (SUB1 BITSPERWORD))))))) (CL:FUNCALL ACTONVMEMFN FIRSTPAGE BUFBASE (SETQ NPAGES (IMIN NBUFS (ADD1 (- LASTPAGE FIRSTPAGE))))) (* ; "Read NBUFS pages from vmem, then write them to output") (COND ((NOT PAGEMAPPED) (* ; "Have to just ship the bits") (\BOUTS STREAM BUFBASE 0 (UNFOLD NPAGES BYTESPERPAGE))) (T (\WRITEPAGES STREAM (SUB1 FIRSTPAGE) (COND ((< NPAGES NBUFS) BUFFERS) (T (* ; "Don't write too many pages on the last pass if NPAGES is less than length of BUFFERS") (to NPAGES as BUF in BUFFERS collect BUF)))))) (add FIRSTPAGE NPAGES)) (RETURN NIL)))
)
)



(* ;; "For MAIKO. \COPYSYS use UNIX-PAGEPERBLOCK.")

(DEFINEQ

(\MAIKO.CHECKFREESPACE
(LAMBDA (FILENAME) (* ; "Edited  1-Apr-90 18:24 by nm") (DECLARE (GLOBALVARS \LDEDESTOVERWRITE \DSKdevice)) (LET ((LASTPAGE (fetch (IFPAGE NActivePages) of \InterfacePage)) (BUFFER (CREATECELL \FIXP)) FULLNAME FILESIZE FREEPAGES HOST) (* ;; "FULLNAME is  UNIX/DSK format pathname with UNIX/DSK. And type is string.") (SETQ FULLNAME (if (NULL FILENAME) then (SETQ HOST (QUOTE DSK)) (\UFS.RECOGNIZE.FILE (CONCAT "{" HOST "}" (OR (UNIX-GETENV "LDEDESTSYSOUT") "~/lisp.virtualmem")) (QUOTE NON) (\GETDEVICEFROMNAME HOST)) else (SETQ HOST (U-CASE (FILENAMEFIELD FILENAME (QUOTE HOST)))) (\UFS.RECOGNIZE.FILE FILENAME (QUOTE NON) (\GETDEVICEFROMNAME HOST)))) (SETQ FULLNAME (CONCAT "{" HOST "}" FULLNAME)) (* ;; "get current free space") (OR (\UFSGetFreeBlock-C FULLNAME BUFFER) (LISPERROR "FILE NOT FOUND" FULLNAME)) (if (IGREATERP LASTPAGE (SETQ FREEPAGES (ITIMES BUFFER LISPPAGE-PER-UNIXBLOCK))) then (* ;; "not enough free space ") (if \LDEDESTOVERWRITE then (* ;; "if possible, try to overwrite") (OR (INFILEP FULLNAME) (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME FULLNAME)) (* ;; "file exist, check file size") (SETQ FILESIZE (GETFILEINFO FULLNAME (QUOTE SIZE))) (if (IGREATERP LASTPAGE (IPLUS FILESIZE FREEPAGES)) then (* ;; "also, not ehough space") (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME FULLNAME) else (* ;; "Remove file, then get enoght space to save") (DELFILE FULLNAME)) else (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME FULLNAME)))))
)
)

(RPAQ? \LDEDESTOVERWRITE NIL)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ LISPPAGE-PER-UNIXBLOCK 2)


(CONSTANTS (LISPPAGE-PER-UNIXBLOCK 2))
)
)



(* ;; 
"Stats code.  On MOD44IO because it writes on the disk and uses records not exported from MOD44IO.  (For this and other reasons, GATHERSTATS only works on Dorados.)"
)

(DEFINEQ

(GATHERSTATS
  [LAMBDA (FILENAME)                                     (* ; "Edited 21-Jan-91 23:33 by jds")

    (* ;; "Enables and disables statistics gathering.  Uses low level file operations to avoid stats file being visible from Lisp b/c the file position is not updated as it is written")

    (DECLARE (GLOBALVARS \STATSON))
    (COND
       ((NEQ \MACHINETYPE \DORADO)
        (ERROR "Stats not implemented for this type of machine" FILENAME))
       [FILENAME (AND \STATSON (GATHERSTATS))
              (SELECTQ (FILENAMEFIELD FILENAME 'HOST)
                  (DSK)
                  (NIL (SETQ FILENAME (PACKFILENAME.STRING 'HOST 'DSK 'BODY FILENAME)))
                  (ERROR "Stats file must be on DSK" FILENAME))
              (SETQ \STATSON T)
              (\GATHERSTATS (PROG [(STREAM (\OPENFILE FILENAME 'OUTPUT 'NEW]
                                                             (* ; 
                "CLose before doing stats, cause file isn't really open from Lisp's point of view.")
                                  (RETURN (fetch (ARRAYP BASE)
                                             of (fetch (M44STREAM FID)
                                                       of (PROG1 STREAM
                                                                  (\CLOSEFILE STREAM)
                                                                  (\M44FLUSHDISKDESCRIPTOR
                                                                   (fetch DEVICE of STREAM))
                                                                  (replace (DSKOBJ DDVALID)
                                                                     of (fetch DEVICE
                                                                               of STREAM)
                                                                     with NIL))]
       (\STATSON (\GATHERSTATS)
              (SETQ \STATSON NIL])
)

(RPAQQ \STATSON NIL)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)


(FILESLOAD (LOADCOMP)
       LLBFS)
)
(PUTPROPS MOD44IO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 
1990 1991 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3982 65711 (\M44AddDiskPages 3992 . 5260) (\M44CloseFile 5262 . 5569) (\M44CompleteFH 
5571 . 9985) (\M44CREATEFILE 9987 . 15917) (\M44DeleteFile 15919 . 17008) (\M44EVENTFN 17010 . 21387) 
(\M44ExtendFilePageMap 21389 . 23440) (\M44FillInMap 23442 . 25792) (\M44GetFileHandle 25794 . 27898) 
(\M44GetFileInfo 27900 . 32083) (\M44GETDATEPROP 32085 . 32567) (\M44GetFileName 32569 . 33006) (
\M44GetPageLoc 33008 . 33809) (\M44KillFilePageMap 33811 . 34182) (\M44MAKEDIRENTRY 34184 . 35915) (
\M44OpenFile 35917 . 42050) (\M44OPENFILEFROMFP 42052 . 43080) (\M44ReadDiskPage 43082 . 45309) (
\M44ReadLeaderPage 45311 . 46763) (\M44ReadPages 46765 . 46982) (\M44SetAccessTimes 46984 . 48269) (
\M44SetEndOfFile 48271 . 49762) (\M44SetFileInfo 49764 . 51018) (\M44SETFILETYPE 51020 . 53633) (
\M44TruncateFile 53635 . 55088) (\M44WriteDiskPage 55090 . 59312) (\M44WriteLeaderPage 59314 . 60172) 
(\M44WritePages 60174 . 62558) (\M44WritePages1 62560 . 65709)) (65745 78564 (\ADDDISKPAGES 65755 . 
67568) (\M44DELETEPAGES 67570 . 71612) (\ASSIGNDISKPAGE 71614 . 74866) (\COUNTDISKFREEPAGES 74868 . 
75405) (\M44MARKPAGEFREE 75407 . 76107) (\M44FLUSHDISKDESCRIPTOR 76109 . 77051) (\MAKELEADERDAS 77053
 . 77764) (DISKFREEPAGES 77766 . 78112) (\M44FREEPAGECOUNT 78114 . 78562)) (81717 96018 (
\M44GENERATEFILES 81727 . 84647) (\M44SORTFILES 84649 . 85026) (\M44GENERATENEXT 85028 . 90673) (
\M44NEXTFILEFN 90675 . 91938) (\M44SORTEDNEXTFILEFN 91940 . 94063) (\M44FILEINFOFN 94065 . 96016)) (
96062 121329 (\M44PARSEFILENAME 96072 . 104104) (\FINDDIRHOLE 104106 . 106089) (\M44PACKFILENAME 
106091 . 106721) (\M44READVERSION 106723 . 107149) (\OPENDISKDESCRIPTOR 107151 . 109258) (
\M44READDIRFID 109260 . 109696) (\M44READDIRNAME 109698 . 110128) (\M44SEARCHDIR 110130 . 112871) (
\M44UNPACKFILENAME 112873 . 121327)) (122158 131181 (\CREATE.FID.FOR.DD 122168 . 122773) (\OPENDISK 
122775 . 124064) (\OPENDISKDEVICE 124066 . 128315) (\OPENDIR 128317 . 129493) (\M44CHECKPASSWORD 
129495 . 130824) (\M44HOSTNAMEP 130826 . 131179)) (131450 134817 (\COPYSYS1 131460 . 134815)) (134878 
136394 (\MAIKO.CHECKFREESPACE 134888 . 136392)) (136742 138730 (GATHERSTATS 136752 . 138728)))))
STOP
\ No newline at end of file
diff --git a/sources/MOD44IO.LCOM b/sources/MOD44IO.LCOM
index a940dcb9..9b2759c6 100644
Binary files a/sources/MOD44IO.LCOM and b/sources/MOD44IO.LCOM differ
