1
2
3
4
5
6
7
8
9
10
11
12
13 get "head"
14 get "bcpl_compiler_head"
15 get "bcpl_metering_head"
16
17 external
18 $( BcplCommand = "bcpl_driver$bcpl"
19 BcplMeters = "bcpl_driver$meters"
20
21 Wdir = "get_wdir_"
22 GetGroupId = "get_group_id_"
23 LevelGet = "cu_$level_get"
24 Initiate = "hcs_$initiate"
25 MakeSeg = "hcs_$make_seg"
26 AclAddOne = "hcs_$acl_add1"
27 AclDelete = "hcs_$acl_delete"
28 UnsnapLinks = "term_$nomakeunknown"
29
30 SymbolTable = "bound_bcpl_$symbol_table"
31
32 BadOpt = "error_table_$badopt"
33 TranslationFailed = "error_table_$translation_failed"
34 $)
35 static
36 $( StaticMeterData = 0
37 StaticMeteringSw = false
38
39 RE = 12
40 RWA = 11
41 Zero = 0
42 One = 1
43 $)
44 manifest
45 $( Empty = $8707070 $)
46
47
48 let BcplCommand () be main
49 $( Errcode, ProgramID := 0, "bcpl"
50 Clp: MONITOR := Open (Console + Write)
51 OUTPUT := MONITOR
52 let StartingTime = GetCpuUsage ()
53
54 if Pl1NumbArgs () = 0 do
55 Complain ("Pathname of source file is required as first argument. Options:*n^a*n^a",
56 "General: list source xref alist check uppercase symbols map optimize quiet",
57 "Compiler debug: time print_meters tree crep pprep 645 ocode")
58
59
60 let Source, Alist = Empty, Empty
61 and List, Time, DumpTree, MetersPrintSw, Check = false, false, false, false, false
62 and Followon = true
63 Xref, LineMap, Optimize := Empty, Empty, Empty
64 Crep, PPrep, OcodeSw, QuietSw, Symbols, UpperCase := false, false, false, false, false, false
65
66 let Names = list "list", "xref", "source", "alist", "tree",
67 "check", "uppercase", "symbols", "map", "optimize",
68 "crep", "pprep", "time", "quiet", "print_meters",
69 "645", "ocode"
70 and Pointers = list lv List, lv Xref, lv Source, lv Alist, lv DumpTree,
71 lv Check, lv UpperCase, lv Symbols, lv LineMap, lv Optimize,
72 lv Crep, lv PPrep, lv Time, lv QuietSw, lv MetersPrintSw,
73 lv Followon, lv OcodeSw
74 and Flags = table OptNegatable, OptNegatable, OptNegatable, OptNegatable, OptNegatable,
75 OptNegatable, OptNegatable, OptNegatable, OptNegatable, OptNegatable,
76 OptNegatable, OptNegatable, OptNegatable, OptNegatable, OptNegatable,
77 OptNegatable | OptNegate, OptNegatable
78 ArgIndex := 2
79 OptionParse (GetNextCommandArg, 17, Names, Pointers, Flags, 0)
80
81 if Xref = Empty do Xref := List
82 if Source = Empty do Source := List | Xref
83 if Alist = Empty do Alist := List
84 Check := Check | Crep
85 if Optimize = Empty do Optimize := Source & not (Check | Symbols)
86 if LineMap = Empty do LineMap := not (Optimize | Check)
87 LineMap := LineMap | Symbols
88
89 HaveListingFile := (Source | Xref | Alist | DumpTree | OcodeSw | PPrep) & not Crep
90 Machine := Followon -> 6180, 645
91 Metering := MetersPrintSw logor StaticMeteringSw
92 let TimeSummary, TimeTemp = Time | HaveListingFile, nil
93
94 OptionString := vec 128
95 SetLength (OptionString, 0)
96 if Source do AddOption ("source")
97 if Xref do AddOption ("xref")
98 if DumpTree do AddOption ("tree")
99 if Alist do AddOption ("alist")
100 if Check do AddOption ("check")
101 if UpperCase do AddOption ("uppercase")
102 if Symbols do AddOption ("symbols")
103 if LineMap do AddOption ("map")
104 if Optimize do AddOption ("optimize")
105 if PPrep do AddOption ("pprep")
106 if OcodeSw do AddOption ("ocode")
107 AddOption (Followon -> "6180", "645")
108
109
110 let Arg = vec 100
111 Pl1ArgString (1, Arg, 100 * 4)
112 let Len = Length (Arg)
113 if Len > 5 do
114 $( let w = vec 5
115 Substr (w, Arg, Len - 4, 5)
116 if EqualString (w, ".bcpl") do SetLength (Arg, Len - 5)
117 $)
118 let Path, Dir, Ent = vec 50, vec 50, vec 10
119 ExpandPathname (Arg, Path)
120 SplitPathname (Path, Dir, Ent)
121 unless Errcode = 0 do Complain (Arg)
122 ProgramName := vec 8
123 MakeBcplString (Ent, 32, ProgramName)
124
125
126
127 if (ProgramName & Right) ge 45000 do Complain ("Not enough room left in stack to perform compilation. Type 'release'.")
128
129 let v = vec 10000
130 UtilitiesInit (v, 10000, StartingTime)
131 let v = vec 20
132 SetHandler ("cleanup", Cleanup, v)
133 SetOverflowMask (true)
134
135 Errorsw := false
136 NAMECHAIN := 0
137
138 GetVersion ()
139
140
141 CompilerDTM, TimeNow := vec 2, vec 2
142 CompilerDTM!0, CompilerDTM!1 := SymbolTable!6, SymbolTable!7
143 RawClockTime (TimeNow)
144 CompilerDTMString, TimeNowString := MakeTimeString (CompilerDTM), MakeTimeString (TimeNow)
145
146 UserID := vec 8
147 let v = vec 8
148 call GetGroupId (v char 32)
149 MakeBcplString (v, 32, UserID)
150
151
152 test Crep
153 then $( INPUT := Open (Console + Read)
154 FilesInfo!0, FilesInfo!1, FilesInfo!2, FilesInfo!3 := "console", 0, 0, 0
155 FileNames!0 := "console"
156 LineCount := FileCount lshift FileShift
157 WriteS (MONITOR, "Type program:*n")
158 $)
159 or $( GetStream (Arg, 0)
160 if HaveListingFile do
161 $( let w = vec 50
162 OUTPUT := Open (EntryName + Write + MultiSegmentFile, Concatenate (w, 32, ProgramName, ".list"))
163 unless Errcode = 0 do Complain (w)
164 Format (OUTPUT, "Compilation listing of file ^s.*n", FilesInfo!0)
165 Format (OUTPUT, "Compilation performed for ^s at ^s.*n", UserID, TimeNowString)
166 Format (OUTPUT, "Compiled by ^s. Compiler updated at ^s.*n",
167 CompilerVersionString, CompilerDTMString)
168 Format (OUTPUT, "Options applied: ^s.*n*n", OptionString)
169 $)
170 WriteS (MONITOR, "BCPL*n")
171 $)
172
173
174 let UsageTemp = nil
175 if Metering do UsageTemp := SaveOldUsage ()
176 if TimeSummary do TimeTemp := GetCpuUsage ()
177 Listing := Source
178
179 LexInit ()
180 let A = CAE ()
181 if Crep & A = 0 & not Errorsw finish
182 if Metering do
183 $( MeterData!TotalLines_Count := TotalLines
184 RecordUsage (SyntaxAnalysis_Meter, UsageTemp)
185 $)
186 Close (INPUT)
187 INPUT := 0
188 if TimeSummary do Wrtime ("CAE", GetCpuUsage () - TimeTemp, "source lines", TotalLines, Time)
189
190
191 if Xref do
192 $( Writech (OUTPUT, Crep -> '*n', '*f')
193 WriteS ("cross reference table*n*n")
194 Pname (NAMECHAIN)
195 $)
196 if DumpTree do
197 $( Writech (OUTPUT, Crep -> '*n', '*f')
198 WriteS ("abstract syntax tree*n*n")
199 Plist (A, 0)
200 $)
201
202
203 unless Errorsw do
204 $( Listing := Alist & Check
205 if Metering do UsageTemp := SaveOldUsage ()
206 if TimeSummary do TimeTemp := GetCpuUsage ()
207 CgInit ()
208 Trans (A)
209 if Metering do
210 $( MeterData!TextWords_Count := TotalWords
211 RecordUsage (SemanticTranslation_Meter, UsageTemp)
212 $)
213 if TimeSummary do Wrtime ("Trans", GetCpuUsage () - TimeTemp, "object words", TotalWords, Time)
214 if Alist & not Check do WriteObjectListing ()
215 $)
216 unless OUTPUT = MONITOR do
217 $( Close (OUTPUT)
218 OUTPUT := MONITOR
219 $)
220
221
222 unless Check | Errorsw do
223 $( let x, y = nil, nil
224 let v = vec 2
225 if Metering do UsageTemp := SaveOldUsage ()
226 call Wdir (Dir char 168)
227 call Initiate (Dir char 168, Ent char 32, "" char 0, lv Zero, lv One, v pointer, lv Errcode)
228 let P = BCPLaddr (v)
229 unless Errcode = 0 do
230 test P = Null
231 then $( call MakeSeg (Dir char 168, Ent char 32, "" char 0, lv RE, v pointer, lv Errcode)
232 P := BCPLaddr (v)
233 if P = Null do Complain ("Unable to create object segment ^a.", ProgramName)
234 $)
235 or call UnsnapLinks (ITS (P, v), lv Errcode)
236 let AclArray, Rings = vec 8, vec 3
237 MakePl1String (UserID, AclArray, 32)
238 AclArray!8 := 0
239 call LevelGet (lv x)
240 Rings!0, Rings!1, Rings!2 := x, x, x
241 call AclAddOne (Dir char 168, Ent char 32, AclArray char 32, lv RWA, Rings, lv Errcode)
242 unless Errcode = 0 do Complain ("Unable to change ACL of object segment ^a.", ProgramName)
243 x := BuildObject (P)
244 SetBitCount (P, x)
245 call AclDelete (Dir char 168, Ent char 32, ITS (AclArray, v) pointer, lv One, lv Errcode)
246 Terminate (P)
247 if Metering do RecordUsage (MakeObject_Meter, UsageTemp)
248 $)
249
250
251 if Metering do
252 $( RecordUsage (DriverOverhead_Meter, 0)
253 let Elapsed, Total, Calls = GetCpuUsage () - StartingTime, 0, 0
254 for i = 0 to MeteringOverhead_Meter - 1 by 3 do
255 Total, Calls := Total + MeterData!i, Calls + MeterData!(i + 1)
256 MeterData!MeteringOverhead_Meter := Elapsed - Total
257 MeterData!(MeteringOverhead_Meter + 1) := Calls
258 for i = 0 to MeteringOverhead_Meter by 3 unless MeterData!i = 0 do MeterData!(i + 2) := Total
259 MeterData!DictionaryDepth_Count := DictionaryDepth
260 if StaticMeteringSw do for i = 0 to Meters_Length do StaticMeterData!i := StaticMeterData!i + MeterData!i
261 if MetersPrintSw do PrintMeters (MeterData)
262 $)
263
264
265 Cleanup ()
266 RevertHandler ("cleanup")
267 Close (MONITOR)
268 if Crep goto Clp
269
270 if Errorsw do
271 $( Errcode := rv TranslationFailed
272 Complain (Arg)
273 $)
274 $)
275
276 and AddOption (s) be
277 test Length (OptionString) = 0
278 then CopyString (s, OptionString)
279 or Concatenate (OptionString, 511, OptionString, " ", s)
280 and Wrtime (ID, Usage, Thing, Nthings, Time) be
281 $( let Rate = Nthings * 1000 * 1000 / Usage
282 Usage := Usage / 100 / 1000
283 let a, b = Usage / 10, Usage rem 10
284 if Time do Format (MONITOR, "^s time ^d.^d, ^d ^s per second.*n", ID, a, b, Rate, Thing)
285 if HaveListingFile do Format (OUTPUT, "*n*n*n^s time ^d.^d, ^d ^s per second.*n", ID, a, b, Rate, Thing)
286 $)
287
288 let BcplMeters () be main
289 $( Errcode, ProgramID := 0, "bcpl$meters"
290 if Pl1NumbArgs () = 0 do Complain ("Options are: print reset meter no_meter")
291
292 let Print, Reset, Start = false, false, Empty
293 let Names = list "print", "reset", "meter"
294 and Pointers = list lv Print, lv Reset, lv Start
295 and Flags = list OptNegatable, OptNegatable, OptNegatable
296 ArgIndex := 1
297 OptionParse (GetNextCommandArg, 3, Names, Pointers, Flags, 0)
298
299 if StaticMeterData = 0 do
300 $( let x = Allocate (Meters_Length + 1)
301 for i = 0 to Meters_Length do x!i := 0
302 StaticMeterData := x
303 $)
304 unless Start = Empty do StaticMeteringSw := Start
305 if Print do
306 $( if StaticMeterData!(MeteringOverhead_Meter + 1) = 0 do Complain ("No metering data available.")
307 OUTPUT := Open (Console + Write)
308 PrintMeters (StaticMeterData)
309 Close (OUTPUT)
310 $)
311 if Reset then for i = 0 to Meters_Length do StaticMeterData!i := 0
312 $)