mim/development/mim/20/mappur.mud

   1 <DEFINE T$PCODE (ID DBNAM "AUX" (PURVEC ,I$PURVEC) (DBVEC ,I$DBVEC) CPC
   2                  DBID)
   3   #DECL ((ID DBID) FIX (DBNAM) STRING
   4          (DBVEC) <VECTOR [REST <OR DB FALSE>]> (PURVEC) <LIST [REST T$PCODE]>
   5          (CPC) T$PCODE)
   6   <COND (<EMPTY? .PURVEC>
   7          <SETG I$PURVEC
   8                <SET PURVEC (<CHTYPE <REST <IUVECTOR <* 20 ,M$$PC-ENTLEN> 0>
   9                                           <* 19 ,PC-ENTLEN>> T$PCODE>)>>)>
  10   ; "Get a DB ID to go with the file ID"
  11   <REPEAT ((CT 1) (DBV .DBVEC) DB)
  12     #DECL ((CT) FIX (DBV) <VECTOR [REST <OR DB FALSE>]>
  13            (DB) <OR DB FALSE>)
  14     <COND (<AND <SET DB <1 .DBV>>
  15                 <T$S=? <DB-NAME .DB> .DBNAM>>
  16            <SET DBID .CT>
  17            <RETURN>)
  18           (<NOT .DB>
  19            <SET DBID .CT>
  20            <1 .DBV [.DBNAM <>]>
  21            <RETURN>)>
  22     <SET CT <+ .CT 1>>
  23     <COND (<EMPTY? <SET DBV <REST .DBV>>>
  24            <SET DBV <IVECTOR <+ <LENGTH .DBVEC> 5> <>>>
  25            <MAPR <>
  26                  <FUNCTION (OLD NEW)
  27                            #DECL ((OLD NEW) VECTOR)
  28                            <1 .NEW <1 .OLD>>>
  29                  .DBVEC .DBV>
  30            <SETG I$DBVEC <SET DBVEC .DBV>>
  31            <CALL SETS DBVEC (,I$DBVEC)>
  32            <PUT .DBVEC .CT [.DBNAM <>]>
  33            <SET DBID .CT>
  34            <RETURN>)>>
  35   <COND (<MAPF <>
  36              <FUNCTION (PV) #DECL ((PV) <OR T$PCODE UVECTOR>)
  37                <REPEAT ()
  38                  <COND (<AND <==? <M$$PC-ID .PV> .ID>
  39                              <==? <M$$PC-DB .PV> .DBID>>
  40                         <MAPLEAVE .PV>)>
  41                  <COND (<EMPTY? <SET PV <REST .PV ,M$$PC-ENTLEN>>>
  42                         <RETURN <>>)>
  43                  <SET PV <CHTYPE .PV T$PCODE>>>>
  44              .PURVEC>)
  45         (T
  46          <SET CPC <1 .PURVEC>>
  47          <COND (<NOT <0? <M$$PC-ID .CPC>>>
  48                 <COND (<==? <LENGTH .CPC> <* 20 ,M$$PC-ENTLEN>>
  49                        <SET CPC <CHTYPE <REST <IUVECTOR <* 20 ,M$$PC-ENTLEN>
  50                                                         0>
  51                                               <* 19 ,PC-ENTLEN>> T$PCODE>>
  52                        <SETG I$PURVEC <SET PURVEC (.CPC !.PURVEC)>>
  53                        <CALL SETS PURVEC ,I$PURVEC>)
  54                       (<SET CPC <CHTYPE <BACK .CPC ,M$$PC-ENTLEN> T$PCODE>>
  55                        <1 .PURVEC .CPC>)>)>
  56          <M$$PC-ID .CPC .ID>
  57          <M$$PC-DB .CPC .DBID>
  58          <M$$PC-DBLOC .CPC -1>
  59          <M$$PC-CORLOC .CPC 0>
  60          <M$$PC-LEN .CPC 0>
  61          .CPC)>>
  62
  63 <DEFINE X$PCODE-PRINT (PC "AUX" (OUTCHAN .OUTCHAN))
  64   #DECL ((PC) T$PCODE)
  65   <T$PRINC "%<" .OUTCHAN>
  66   <T$PRIN1 PCODE .OUTCHAN>
  67   <T$PRINC !\  .OUTCHAN>
  68   <T$PRIN1 <M$$PC-ID .PC> .OUTCHAN>
  69   <T$PRINC !\  .OUTCHAN>
  70   <T$PRIN1 <DB-NAME <NTH ,I$DBVEC:VECTOR <M$$PC-DB .PC>>:VECTOR> .OUTCHAN>
  71   <T$PRINC !\> .OUTCHAN>>
  72 \f
  73 <DEFINE I$GET-DB (PC "AUX" (DBVEC ,I$DBVEC) DB (DBID <M$$PC-DB .PC>) CC ERR)
  74   #DECL ((PC) T$PCODE (DBVEC) <VECTOR [REST <OR DB FALSE>]> (DBID) FIX
  75          (DB) DB (CC) <OR FIX FALSE>)
  76   <SET DB <NTH .DBVEC .DBID>>
  77   <PROG ()
  78     <COND (<NOT <SET CC <DB-CHANNEL .DB>>>
  79            <COND (<SET CC <CALL SYSOP GTJFN-S-S %<CHTYPE <ORB ,GJ-OLD ,GJ-SHT>
  80                                                          FIX>
  81                                 <DB-NAME .DB>>>
  82                   <COND (<SET ERR
  83                               <CALL SYSOP OPENF
  84                                     .CC %<CHTYPE <ORB ,OF-RD ,OF-THW ,OF-PLN>
  85                                                  FIX>>>
  86                          <DB-CHANNEL .DB .CC>)
  87                         (<OR <==? <1 .ERR> *600131*>
  88                              ; "Entire file structure full"
  89                              <==? <1 .ERR> *601727*>>
  90                          ; "Insufficient system resources"
  91                          <CALL SYSOP RLJFN .CC>
  92                          ; "Free the JFN"
  93                          <CALL PRINT *101* <DB-NAME .DB>
  94                                <LENGTH <DB-NAME .DB>>>
  95                          ; "Print a message"
  96                          <CALL SYSOP ESOUT %<STRING "Can't open database:  "
  97                                                     <ASCII 0>>>
  98                          <CALL SYSOP ERSTR *101* <PUTLHW <1 .ERR>
  99                                                          *400000*> 0>
 100                          <CALL QUIT *601727* ; "MONX01">
 101                          ; "Quit with special code, then try again
 102                             if continued"
 103                          <AGAIN>)
 104                         (T
 105                          <CALL SYSOP RLJFN .CC>
 106                          <SET CC .ERR>)>)>
 107            <COND (<NOT .CC>
 108                   <CALL PRINT *101* <DB-NAME .DB> <LENGTH <DB-NAME .DB>>>
 109                   <CALL PRINT *101* "
 110 " 2>
 111                   <CALL FATAL "Can't find database">
 112                   <AGAIN>)>)>>
 113   .CC>
 114
 115 <DEFINE X$PLOAD (PC "AUX" (JFN <I$GET-DB .PC>) FS IV DV DIRLOC ENT
 116                  GCP)
 117   #DECL ((PC) T$PCODE (JFN) FIX (FS) T$ZONE (DIRLOC) FIX
 118          (IV DV) UVECTOR (ENT) <OR UVECTOR FALSE> (GCP) T$GC-PARAMS)
 119   <COND (<G=? <M$$PC-DBLOC .PC> 0>
 120          ; "Do we already know where this is?"
 121          ; "Takes JFN, pcode; reads stuff in somewhere"
 122          <I$MAP-IN .JFN .PC>)
 123         (T
 124          <COND (<NOT ,I$FBIN-SPACE>
 125                 <SETG I$FBIN-SPACE <T$CREATE-NEW-SPACE 1024>>
 126                 <SET FS ,I$FBIN-SPACE>
 127                 <GCSFLG <SET GCP <GC-PARAMS .FS>> -1>
 128                 <T$SET-ZONE .FS>
 129                 <SETG I$IND-VEC <IUVECTOR ,T$PSIZE 0>>
 130                 <SETG I$DIR-VEC <IUVECTOR ,T$PSIZE 0>>
 131                 <T$RESTORE-ZONE>)
 132                (<SET FS ,I$FBIN-SPACE>)>
 133          <SET IV ,I$IND-VEC>
 134          <SET DV ,I$DIR-VEC>
 135          <I$MAP-PAGE .JFN .IV ,ALLOC-PAGE T>
 136          <SET DIRLOC <I$HASH-PCODE .PC .IV>>
 137          <I$MAP-PAGE .JFN .DV .DIRLOC T>
 138          <1 .DV <1 .DV>>
 139          ; "Unshare this loser"
 140          <COND (<SET ENT <I$BINSRC .PC .DV>>
 141                 <M$$PC-DBLOC .PC <RHW <DIR-PAGE&LOC .ENT>>>
 142                 <M$$PC-LEN .PC <- <LHW <DIR-PAGE&LOC .ENT>>
 143                                   ,SAV-HEADER-LEN>>
 144                 <I$MAP-IN .JFN .PC>)
 145                (<T$ERROR %<P-E "MISSING-SAV-FILE"> .PC I$PLOAD>)>)>>
 146
 147 <DEFINE I$HASH-PCODE (PC IV "AUX" (ID <M$$PC-ID .PC>) DIRNUM)
 148   #DECL ((PC) T$PCODE (IV) UVECTOR (ID DIRNUM) FIX)
 149   <SET DIRNUM <MOD .ID <ALLOC-DIRCNT .IV>>>
 150   <NTH .IV <+ ,ALLOC-HEADER-LEN <* .DIRNUM ,ALLOC-DIR-LEN>
 151               ,ALLOC-DIRLOC>>>
 152
 153 <DEFINE I$MAP-PAGE (JFN UV PGNO ALLOW? "OPTIONAL" (NPGS 1) "AUX" EXBIT
 154                     ERR)
 155   #DECL ((JFN PGNO NPGS) FIX (UV) <OR UVECTOR FIX>)
 156   <COND (.ALLOW? <SET EXBIT *400*>)>
 157   <PROG ()
 158    <COND (<SET ERR
 159                <CALL SYSOP PMAP <PUTLHW .PGNO .JFN>
 160                      <PUTLHW <ADDRESS-PAGE <CALL VALUE .UV>> *400000*>
 161                      <COND (<1? .NPGS>
 162                             <ORB *100000000000* <PUTLHW 0 .EXBIT>>)
 163                            (T
 164                             <PUTLHW .NPGS <ORB *500000* .EXBIT>>)>>>)
 165          (<OR <==? <1 .ERR> *600131*>
 166               <==? <1 .ERR> *601727*>>
 167           <CALL SYSOP ESOUT %<STRING "Can't map in pages:  "
 168                                      <ASCII 0>>>
 169           <CALL SYSOP ERSTR *101* <PUTLHW <1 .ERR> *400000*> 0>
 170           <CALL QUIT *601727* ;"MONX01">
 171           <AGAIN>)
 172          (T
 173           <ERROR %<P-E "CANT-MAP-IN-PAGES"> .ERR X$PLOAD>)>>>
 174
 175
 176 ; "Binary search of directory (in DV) for pcode's entry."
 177 <DEFINE I$BINSRC (PC DV "AUX" (ID <M$$PC-ID .PC>) (CNT <DIR-COUNT .DV>)
 178                   (EXIT .CNT))
 179   #DECL ((PC) T$PCODE (DV) <UVECTOR [REST FIX]> (ID) FIX (CNT) FIX)
 180   <SET DV <REST .DV ,DIR-HEADER>>
 181   <REPEAT UP ()
 182     <COND (<0? <SET CNT </ .CNT 2>>>
 183            <REPEAT ()
 184              <COND (<L=? .EXIT 0>
 185                     <RETURN <> .UP>)>
 186              <SET EXIT <- .EXIT 1>>
 187              <COND (<==? .ID <DIR-FILE-ID .DV>>
 188                     <RETURN .DV .UP>)>
 189              <SET DV <REST .DV ,DIR-ENTRY-SIZE>>>)
 190           (<==? .ID <DIR-FILE-ID .DV>>
 191            <RETURN .DV>)
 192           (<G=? .ID <NTH .DV <- <* ,DIR-ENTRY-SIZE <+ .CNT 1>> 1>>>
 193            <SET DV <REST .DV <* ,DIR-ENTRY-SIZE .CNT>>>)>
 194     <SET EXIT <- .EXIT .CNT>>>>
 195
 196 <DEFINE I$MAP-IN (JFN PC "AUX" (RLEN <+ <M$$PC-LEN .PC> ,SAV-HEADER-LEN>)
 197                   PGN SADR NPGS)
 198   #DECL ((NPGS JFN RLEN SADR) FIX (PC) T$PCODE
 199          (PGN) <OR FIX FALSE>)
 200   <COND (<OR <NOT <SET PGN
 201                        <T$GET-BLOCK-OF-SPACE <SET NPGS
 202                                                 <ADDRESS-PAGE
 203                                                   <+ .RLEN <- ,T$PSIZE 1>>>>
 204                                              ,M$$MP-IDENT>>>
 205              <L? .PGN 0>>
 206          <ERROR %<P-E "CANT-GET-PAGES"> .PC I$MAP-IN>)
 207         (T
 208          <SET SADR <PAGE-ADDRESS .PGN>>
 209          <I$MAP-PAGE .JFN .SADR <M$$PC-DBLOC .PC> <> .NPGS>
 210          <M$$PC-CORLOC .PC <+ .SADR ,SAV-HEADER-LEN>>)>>
 211
 212 <DEFINE X$PURCLN ("AUX" PV DV FS GCP)
 213   #DECL ((PV) <LIST [REST T$PCODE]> (DV) <VECTOR [REST <OR DB FALSE>]>
 214          (FS) T$ZONE (GCP) T$GC-PARAMS)
 215   <COND (,I$FBIN-SPACE
 216          <T$RETURN-PAGES ,M$$MP-IDENT>          ; "Get rid of pages"
 217          <COND (<GASSIGNED? I$PURVEC>
 218                 ; "Unmap directory pages"
 219                 <I$FLUSH-PAGES <ADDRESS-PAGE
 220                                 <GCSMIN <SET GCP
 221                                              <GC-PARAMS
 222                                               <SET FS ,I$FBIN-SPACE>>>>>
 223                                 2>
 224                 <SET PV ,I$PURVEC>
 225                 <SET DV ,I$DBVEC>
 226                 ; "Say nothing is mapped in"
 227                 <MAPF <>
 228                   <FUNCTION (PC)
 229                     #DECL ((PC) <OR T$PCODE <UVECTOR [REST FIX]>>)
 230                     <REPEAT ()
 231                       ; "Map the pages out"
 232                       <M$$PC-CORLOC .PC 0>
 233                       ; "Forget where they are in the sav file, to allow
 234                          us to compact it."
 235                       <M$$PC-DBLOC .PC -1>
 236                       <M$$PC-LEN .PC 0>
 237                       <COND (<EMPTY? <SET PC <REST .PC ,M$$PC-ENTLEN>>>
 238                              <RETURN>)>>>
 239                   .PV>
 240                 ; "Flush channels to sav files"
 241                 <MAPF <>
 242                   <FUNCTION (DD)
 243                     <COND (<AND .DD
 244                                 <DB-CHANNEL .DD>>
 245                            <CALL SYSOP CLOSF <DB-CHANNEL .DD>>
 246                            <DB-CHANNEL .DD <>>)>>
 247                   .DV>)>)>
 248   T>