1 <DEFINE T$PCODE (ID DBNAM "AUX" (PURVEC ,I$PURVEC) (DBVEC ,I$DBVEC) CPC
3 #DECL ((ID DBID) FIX (DBNAM) STRING
4 (DBVEC) <VECTOR [REST <OR DB FALSE>]> (PURVEC) <LIST [REST T$PCODE]>
6 <COND (<EMPTY? .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>]>
14 <COND (<AND <SET DB <1 .DBV>>
15 <T$S=? <DB-NAME .DB> .DBNAM>>
23 <COND (<EMPTY? <SET DBV <REST .DBV>>>
24 <SET DBV <IVECTOR <+ <LENGTH .DBVEC> 5> <>>>
27 #DECL ((OLD NEW) VECTOR)
30 <SETG I$DBVEC <SET DBVEC .DBV>>
31 <CALL SETS DBVEC (,I$DBVEC)>
32 <PUT .DBVEC .CT [.DBNAM <>]>
36 <FUNCTION (PV) #DECL ((PV) <OR T$PCODE UVECTOR>)
38 <COND (<AND <==? <M$$PC-ID .PV> .ID>
39 <==? <M$$PC-DB .PV> .DBID>>
41 <COND (<EMPTY? <SET PV <REST .PV ,M$$PC-ENTLEN>>>
43 <SET PV <CHTYPE .PV T$PCODE>>>>
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>
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>>
63 <DEFINE X$PCODE-PRINT (PC "AUX" (OUTCHAN .OUTCHAN))
65 <T$PRINC "%<" .OUTCHAN>
66 <T$PRIN1 PCODE .OUTCHAN>
68 <T$PRIN1 <M$$PC-ID .PC> .OUTCHAN>
70 <T$PRIN1 <DB-NAME <NTH ,I$DBVEC:VECTOR <M$$PC-DB .PC>>:VECTOR> .OUTCHAN>
71 <T$PRINC !\> .OUTCHAN>>
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>>
78 <COND (<NOT <SET CC <DB-CHANNEL .DB>>>
79 <COND (<SET CC <CALL SYSOP GTJFN-S-S %<CHTYPE <ORB ,GJ-OLD ,GJ-SHT>
84 .CC %<CHTYPE <ORB ,OF-RD ,OF-THW ,OF-PLN>
87 (<OR <==? <1 .ERR> *600131*>
88 ; "Entire file structure full"
89 <==? <1 .ERR> *601727*>>
90 ; "Insufficient system resources"
91 <CALL SYSOP RLJFN .CC>
93 <CALL PRINT *101* <DB-NAME .DB>
94 <LENGTH <DB-NAME .DB>>>
96 <CALL SYSOP ESOUT %<STRING "Can't open database: "
98 <CALL SYSOP ERSTR *101* <PUTLHW <1 .ERR>
100 <CALL QUIT *601727* ; "MONX01">
101 ; "Quit with special code, then try again
105 <CALL SYSOP RLJFN .CC>
108 <CALL PRINT *101* <DB-NAME .DB> <LENGTH <DB-NAME .DB>>>
111 <CALL FATAL "Can't find database">
115 <DEFINE X$PLOAD (PC "AUX" (JFN <I$GET-DB .PC>) FS IV DV DIRLOC ENT
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"
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>
129 <SETG I$IND-VEC <IUVECTOR ,T$PSIZE 0>>
130 <SETG I$DIR-VEC <IUVECTOR ,T$PSIZE 0>>
132 (<SET FS ,I$FBIN-SPACE>)>
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>
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>>
145 (<T$ERROR %<P-E "MISSING-SAV-FILE"> .PC I$PLOAD>)>)>>
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>
153 <DEFINE I$MAP-PAGE (JFN UV PGNO ALLOW? "OPTIONAL" (NPGS 1) "AUX" EXBIT
155 #DECL ((JFN PGNO NPGS) FIX (UV) <OR UVECTOR FIX>)
156 <COND (.ALLOW? <SET EXBIT *400*>)>
159 <CALL SYSOP PMAP <PUTLHW .PGNO .JFN>
160 <PUTLHW <ADDRESS-PAGE <CALL VALUE .UV>> *400000*>
162 <ORB *100000000000* <PUTLHW 0 .EXBIT>>)
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: "
169 <CALL SYSOP ERSTR *101* <PUTLHW <1 .ERR> *400000*> 0>
170 <CALL QUIT *601727* ;"MONX01">
173 <ERROR %<P-E "CANT-MAP-IN-PAGES"> .ERR X$PLOAD>)>>>
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>)
179 #DECL ((PC) T$PCODE (DV) <UVECTOR [REST FIX]> (ID) FIX (CNT) FIX)
180 <SET DV <REST .DV ,DIR-HEADER>>
182 <COND (<0? <SET CNT </ .CNT 2>>>
186 <SET EXIT <- .EXIT 1>>
187 <COND (<==? .ID <DIR-FILE-ID .DV>>
189 <SET DV <REST .DV ,DIR-ENTRY-SIZE>>>)
190 (<==? .ID <DIR-FILE-ID .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>>>>
196 <DEFINE I$MAP-IN (JFN PC "AUX" (RLEN <+ <M$$PC-LEN .PC> ,SAV-HEADER-LEN>)
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
203 <+ .RLEN <- ,T$PSIZE 1>>>>
206 <ERROR %<P-E "CANT-GET-PAGES"> .PC I$MAP-IN>)
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>>)>>
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)
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
222 <SET FS ,I$FBIN-SPACE>>>>>
226 ; "Say nothing is mapped in"
229 #DECL ((PC) <OR T$PCODE <UVECTOR [REST FIX]>>)
231 ; "Map the pages out"
233 ; "Forget where they are in the sav file, to allow
237 <COND (<EMPTY? <SET PC <REST .PC ,M$$PC-ENTLEN>>>
240 ; "Flush channels to sav files"
245 <CALL SYSOP CLOSF <DB-CHANNEL .DD>>
246 <DB-CHANNEL .DD <>>)>>