1 * *************************************************************************
2 * *
3 * Copyright c 1980 by Centre Interuniversitaire de Calcul de Grenoble *
4 * and Institut National de Recherche en Informatique et Automatique *
5 * *
6 ************************************************************************* *
7
8
9
10
11 * HISTORY COMMENTS:
12 1 change86-09-11JMAthane, approve86-09-11MCR7521,
13 audit86-09-15JPFauche, install86-11-12MR12.0-1212:
14 Release 8.03 for MR12
15 END HISTORY COMMENTS *)
16
17
18 $OPTIONS page $
19
20 $OPTIONS switch trace := true ; switch security := true ; t + $
21 PROGRAM genere ;
22 $IMPORT
23 * IMPORTED PROCEDURES *
24 'RACINE pascal' :
25 crealfabox,
26 error,
27 nextline,
28 recadre,
29 statement_begins,
30 statement_ends ;
31 'STATE pascal' :
32 enterundlab,
33 gencstecode ;
34 'CONTEXTTABLE pascal' :
35 create_konst_box ;
36
37 * FROM PL1 *
38 'pascal_gen_entry_point pl1' : genentrypoint ;
39 'pascal_gen_bin_area pl1' : genbinarea ;
40 'pascal_gen_rel_$text pl1' : genreltext ;
41 * IMPORTED VARIABLES *
42 'RACINE pascal' :
43 alfaptr,
44 bufval,
45 codelist,
46 currentnode,
47 declarationpart,
48 environt,
49 envstandard,
50 errtotal,
51 fastoperator,
52 init_fsb_trap_flag,
53 init_fsb_trap_info_place,
54 init_fsb_trap_links_place,
55 init_fsb_trap_number_of_files,
56 interactive,
57 iowarnings,
58 level,
59 longprofile,
60 longstring,
61 mapswitch,
62 mpcogout,
63 profilewordcount,
64 profptr,
65 progname,
66 selectivetable,
67 statnbr,
68 textfilectp,
69 version ;
70 'STATE pascal' :
71 asscheck,
72 errorctp,
73 inputctp,
74 linktomain,
75 linktomainplace,
76 outputctp,
77 tmax ;
78 'DECLARE pascal' :
79 lkc,
80 nextalf,
81 symbtabl ;
82 'pascal_context_ alm' :
83 asciiformataddr,
84 nilformataddr,
85 octalformataddr,
86 realformataddr,
87 usednamesaddr$
88
89 $EXPORT
90 cb,
91 closefile,
92 codesymb,
93 enterreftosymbol,
94 exitlabel,
95 fichinter,
96 genalfa,
97 genc,
98 gencodfonct,
99 gendesca,
100 gendescb,
101 geneism,
102 genetrace,
103 geninsertion,
104 genlongprofileref,
105 genmulticsnil,
106 genpgexit,
107 genprcentry,
108 genprcexit,
109 genprofileref,
110 genprolog,
111 genr,
112 genstand,
113 genstring,
114 gen_init_fsb_trap_structures,
115 ic,
116 illegal_generation,
117 indfich,
118 infich,
119 initgen,
120 initiozone,
121 inser,
122 longint,
123 mainloc,
124 mfari1,
125 mfari2,
126 mfari3,
127 mfreg1,
128 mfreg2,
129 mfreg3,
130 outcode,
131 tagsymb,
132 usednameaddr,
133 writecode,
134 writout $
135
136
137
138
139 $OPTIONS page $
140
141 $INCLUDE 'CONSTTYPE' $
142
143
144
145 $OPTIONS page $
146
147 VAR
148 * IMPORTED VARIABLES *
149
150 * FROM RACINE *
151 alfaptr : ctp ;
152 bufval : ARRAY 1..maxval OF char ;
153 codelist : boolean ;
154 currentnode : blocknodeptr ;
155 declarationpart : boolean ;
156 environt : contexte ;
157 envstandard : stdkind ;
158 errtotal : integer ;
159 fastoperator : boolean ;
160 init_fsb_trap_flag : boolean ;
161 init_fsb_trap_info_place,
162 init_fsb_trap_links_place,
163 init_fsb_trap_number_of_files : integer ;
164
165 interactive : boolean ;
166 iowarnings : boolean ;
167 level : levrange ; mpcogout : text ;
168 longprofile : boolean ;
169 longstring : integer ;
170 mapswitch : boolean ;
171 profilewordcount : integer ;
172 profptr : profareaptr ;
173 progname : alfaid ;
174 selectivetable : boolean ;
175 statnbr : integer ;
176 textfilectp : ctp ;
177 version : integer ;
178
179 * FROM STATE *
180 asscheck : boolean ;
181 errorctp : ctp ;
182 inputctp : ctp ;
183 linktomain : boolean ;
184 linktomainplace : integer ;
185 outputctp : ctp ;
186 tmax : integer ;
187
188 * FROM DECLARE *
189 lkc : integer ;
190 nextalf : ctp ;
191 symbtabl : boolean ;
192
193 * FROM ALM *
194 realformataddr,
195 nilformataddr,
196 asciiformataddr,
197 octalformataddr : ctp ;
198 usednamesaddr : usednamesptr ;
199
200 * EXPORTABLE VARIABLES *
201
202 cb : integer ; * GIVES THE RELATIVE ADDRESS *
203 * IN THE CURRENT PROCEDURE *
204 codesymb : ARRAY instword OF alfa ; * MNEMONICS OF ALM INSTRUCTIONS *
205 fichinter : ^binartype ;
206 * CONTAINS THE CODE AND DATA GENERATED *
207 genetrace : levtrace ; * TO KNOW IF A TRACE IS DONE ON GENERATION *
208 ic : integer ; * GIVES THE ABSOLUTE ADDRESS IN TEXT SECTION *
209 illegal_generation : boolean ; * TRUE IF ILLEGAL INSTRUCTION GENERATION CALLED *
210 indfich : integer ; * GIVES THE FIRST FREE ENTRY IN FICHINTER *
211 mainloc : integer ; * LOCATION WORDS OF FIRST INSTRUCTION OF MAIN *
212 mfari1, mfari2, mfari3 : zari ; * BITS 012 IN MF'S EIS *
213 mfreg1, mfreg2, mfreg3 : mreg ; * REG. MOD. IN MF'S EIS *
214 outcode : boolean ; * TO KNOW IF ALM GENERATED CODE MUST BE PRINTED *
215 tagsymb : ARRAY tag OF PACKED ARRAY 1..4 OF char ; * MNEM. FOR TAGS *
216 usednameaddr : ctp ; * PTR TO USED NAME IF ANY FOR "-list" OPTION *
217 writecode : boolean ; * TO KNOW IF OPTION 'C' IS '+' *
218
219 * LOCAL VARIABLES *
220
221 gversion : integer ; * VERSION OF GENERE *
222 $OPTIONS compile = security $
223 forbiset : ARRAY instword OF forset ; * GIVES FORBIDDEN PTR FIELD FOR *
224 * IEISM FORBIDDEN TAG FOR ISTAND *
225 $OPTIONS compile = true $
226
227 * BITS MASKS FOR INSTRUCTION CODING. ALL MASKS ARE ON HALF-WORD. *
228 codebin : ARRAY instword OF integer ; * OPERATION CODE *
229 valari : ARRAY zari OF integer ; * ARI FIELD FOR EIS MF'S *
230 valcar : ARRAY lgcar OF integer ; * CHARACTER DATA TYPE *
231 valpos : ARRAY lgcar OF integer ; * GIVES THE MULTIPLICATOR TO CODE *
232 * THE CN FIELD IN ALPHANUMERIC AND NUMERIC *
233 * OPERAND DESCRIPTOR *
234 valptr : ARRAY zptr OF integer ; * PTR FIELDS FOR EIS MULTIWORD *
235 valreg : ARRAY preg OF integer ; * POINTER REGISTER *
236
237
238 AAVALSIG : ARRAYTYPSIG OF INTEGER; * SIGN AND DECIMAL TYPE *
239 AAVALABC : ARRAYZABC OF INTEGER; * ABC FIELD FOR REPEAT INST. *
240
241
242
243 prsymb : ARRAY preg OF PACKED ARRAY 1..4 OF char ; * MNEMONICS FOR P. REG. *
244 charsize : ARRAY lgcar OF PACKED ARRAY 1..4 OF char ;
245 * USED TO CODE MNEMONICS OF ALPHANUMERIC *
246 * OPERAND DESCRIPTORS *
247 $OPTIONS compile = security $
248 forbitag : ARRAY forset OF SET OF tag ; * FORBIDDEN TAGS FOR ISTAND : *
249 * S0 -> NONE *
250 * S1 -> DUDL *
251 * S2 -> CISCSCR *
252 * S3 -> DUDLCISCSCR *
253 * S4 -> ALL EXCEPT AUQUALQLX0..X7 *
254 * S5 -> ALL *
255 forbiptr : ARRAY forset OF SET OF zptr ; * FORBIDDEN PTR FIELDS EISM : *
256 * S0 -> ALL *
257 * S1 -> T AND R MUST BE ZERO *
258 * S2 -> P AND R MUST BE ZERO *
259 * S3 -> R MUST BE ZERO *
260 * S4 -> NONE *
261 $OPTIONS compile = true $
262
263
264 $OPTIONS page $
265
266 $VALUE
267
268 codesymb =
269 'eaa ' 'eaq ' 'eax0 ' 'eax1 ' 'eax2 ' 'eax3 ' 'eax4 '
270 'eax5 ' 'eax6 ' 'eax7 ' 'lca ' 'lcaq ' 'lcq ' 'lcx0 '
271 'lcx1 ' 'lcx2 ' 'lcx3 ' 'lcx4 ' 'lcx5 ' 'lcx6 ' 'lcx7 '
272 'lda ' 'ldac ' 'ldaq ' 'ldi ' 'ldq ' 'ldqc ' 'ldx0 '
273 'ldx1 ' 'ldx2 ' 'ldx3 ' 'ldx4 ' 'ldx5 ' 'ldx6 ' 'ldx7 '
274 'lreg ' 'lxl0 ' 'lxl1 ' 'lxl2 ' 'lxl3 ' 'lxl4 ' 'lxl5 '
275 'lxl6 ' 'lxl7 ' 'sreg ' 'sta ' 'stac ' 'stacq ' 'staq '
276 'stc1 ' 'stc2 ' 'stcd ' 'sti ' 'stq ' 'stt ' 'stx0 '
277 'stx1 ' 'stx2 ' 'stx3 ' 'stx4 ' 'stx5 ' 'stx6 ' 'stx7 '
278 'stz ' 'sxl0 ' 'sxl1 ' 'sxl2 ' 'sxl3 ' 'sxl4 ' 'sxl5 '
279 'sxl6 ' 'sxl7 ' 'alr ' 'als ' 'arl ' 'ars ' 'llr '
280 'lls ' 'lrl ' 'lrs ' 'qlr ' 'qls ' 'qrl ' 'qrs '
281 'ada ' 'adaq ' 'adl ' 'adla ' 'adlaq ' 'adlq ' 'adlx0 '
282 'adlx1 ' 'adlx2 ' 'adlx3 ' 'adlx4 ' 'adlx5 ' 'adlx6 ' 'adlx7 '
283 'adq ' 'adx0 ' 'adx1 ' 'adx2 ' 'adx3 ' 'adx4 ' 'adx5 '
284 'adx6 ' 'adx7 ' 'aos ' 'asa ' 'asq ' 'asx0 ' 'asx1 '
285 'asx2 ' 'asx3 ' 'asx4 ' 'asx5 ' 'asx6 ' 'asx7 ' 'awca '
286 'awcq ' 'sba ' 'sbaq ' 'sbla ' 'sblaq ' 'sblq ' 'sblx0 '
287 'sblx1 ' 'sblx2 ' 'sblx3 ' 'sblx4 ' 'sblx5 ' 'sblx6 ' 'sblx7 '
288 'sbq ' 'sbx0 ' 'sbx1 ' 'sbx2 ' 'sbx3 ' 'sbx4 ' 'sbx5 '
289 'sbx6 ' 'sbx7 ' 'ssa ' 'ssq ' 'ssx0 ' 'ssx1 ' 'ssx2 '
290 'ssx3 ' 'ssx4 ' 'ssx5 ' 'ssx6 ' 'ssx7 ' 'swca ' 'swcq '
291 'mpf ' 'mpy ' 'div ' 'divf ' 'neg ' 'negl ' 'cmg '
292 'cmk ' 'cmpa ' 'cmpaq ' 'cmpq ' 'cmpx0 ' 'cmpx1 ' 'cmpx2 '
293 'cmpx3 ' 'cmpx4 ' 'cmpx5 ' 'cmpx6 ' 'cmpx7 ' 'cwl ' 'szn '
294 'sznc '
295 * ********************************** *
296 'dfld ' 'fld ' 'dfst ' 'dfstr ' 'fst ' 'fstr ' 'dfad '
297 'dufa ' 'fad ' 'ufa ' 'dfsb ' 'dufs ' 'fsb ' 'ufs '
298 'dfmp ' 'dufm ' 'fmp ' 'ufm ' 'dfdi ' 'dfdv ' 'fdi '
299 'fdv ' 'fneg ' 'fno ' 'dfrd ' 'frd ' 'dfcmg ' 'dfcmp '
300 'fcmg ' 'fcmp ' 'ade ' 'fszn ' 'lde ' 'ste '
301 * ********************************** *
302 'ana ' 'anaq ' 'anq ' 'ansa ' 'ansq ' 'ansx0 ' 'ansx1 '
303 'ansx2 ' 'ansx3 ' 'ansx4 ' 'ansx5 ' 'ansx6 ' 'ansx7 ' 'anx0 '
304 'anx1 ' 'anx2 ' 'anx3 ' 'anx4 ' 'anx5 ' 'anx6 ' 'anx7 '
305 'ora ' 'oraq ' 'orq ' 'orsa ' 'orsq ' 'orsx0 ' 'orsx1 '
306 'orsx2 ' 'orsx3 ' 'orsx4 ' 'orsx5 ' 'orsx6 ' 'orsx7 ' 'orx0 '
307 'orx1 ' 'orx2 ' 'orx3 ' 'orx4 ' 'orx5 ' 'orx6 ' 'orx7 '
308 'era ' 'eraq ' 'erq ' 'ersa ' 'ersq ' 'ersx0 ' 'ersx1 '
309 'ersx2 ' 'ersx3 ' 'ersx4 ' 'ersx5 ' 'ersx6 ' 'ersx7 ' 'erx0 '
310 'erx1 ' 'erx2 ' 'erx3 ' 'erx4 ' 'erx5 ' 'erx6 ' 'erx7 '
311 'cana ' 'canaq ' 'canq ' 'canx0 ' 'canx1 ' 'canx2 ' 'canx3 '
312 'canx4 ' 'canx5 ' 'canx6 ' 'canx7 ' 'cnaa ' 'cnaaq ' 'cnaq '
313 'cnax0 ' 'cnax1 ' 'cnax2 ' 'cnax3 ' 'cnax4 ' 'cnax5 ' 'cnax6 '
314 'cnax7 '
315 * ********************************** *
316 'easp0 ' 'easp1 ' 'easp2 ' 'easp3 ' 'easp4 ' 'easp5 ' 'easp6 '
317 'easp7 ' 'eawp0 ' 'eawp1 ' 'eawp2 ' 'eawp3 ' 'eawp4 ' 'eawp5 '
318 'eawp6 ' 'eawp7 ' 'epbp0 ' 'epbp1 ' 'epbp2 ' 'epbp3 ' 'epbp4 '
319 'epbp5 ' 'epbp6 ' 'epbp7 ' 'epp0 ' 'epp1 ' 'epp2 ' 'epp3 '
320 'epp4 ' 'epp5 ' 'epp6 ' 'epp7 ' 'lpri ' 'lprp0 ' 'lprp1 '
321 'lprp2 ' 'lprp3 ' 'lprp4 ' 'lprp5 ' 'lprp6 ' 'lprp7 ' 'spbp0 '
322 'spbp1 ' 'spbp2 ' 'spbp3 ' 'spbp4 ' 'spbp5 ' 'spbp6 ' 'spbp7 '
323 'spri ' 'spri0 ' 'spri1 ' 'spri2 ' 'spri3 ' 'spri4 ' 'spri5 '
324 'spri6 ' 'spri7 ' 'sprp0 ' 'sprp1 ' 'sprp2 ' 'sprp3 ' 'sprp4 '
325 'sprp5 ' 'sprp6 ' 'sprp7 ' 'adwp0 ' 'adwp1 ' 'adwp2 ' 'adwp3 '
326 'adwp4 ' 'adwp5 ' 'adwp6 ' 'adwp7 ' 'epaq '
327 * ********************************** *
328 'call6 ' 'ret ' 'rtcd ' 'teo ' 'teu ' 'tmi ' 'tmoz '
329 'tnc ' 'tnz ' 'tov ' 'tpl ' 'tpnz ' 'tra ' 'trc '
330 'trtf ' 'trtn ' 'tsp0 ' 'tsp1 ' 'tsp2 ' 'tsp3 ' 'tsp4 '
331 'tsp5 ' 'tsp6 ' 'tsp7 ' 'tss ' 'tsx0 ' 'tsx1 ' 'tsx2 '
332 'tsx3 ' 'tsx4 ' 'tsx5 ' 'tsx6 ' 'tsx7 ' 'ttf ' 'ttn '
333 'tze '
334 * ********************************** *
335 'rccl ' 'drl ' 'xec ' 'xed ' 'mme ' 'mme2 ' 'mme3 '
336 'mme4 ' 'nop ' 'puls1 ' 'puls2 ' 'sra ' 'sbar ' 'bcd '
337 'gtb '
338 * ********************************** *
339 'lbar ' 'lcpr ' 'ldbr ' 'ldt ' 'lptp ' 'lptr ' 'lra '
340 'lsdp ' 'lsdr ' 'rcu ' 'scpr ' 'scu ' 'sdbr ' 'sptp '
341 'sptr ' 'ssdp ' 'ssdr ' 'camp ' 'cams ' 'rmcm ' 'rscr '
342 'rsw ' 'cioc ' 'smcm ' 'smic ' 'sscr ' 'absa ' 'dis '
343 * ********************************** *
344 'aar0 ' 'aar1 ' 'aar2 ' 'aar3 ' 'aar4 ' 'aar5 ' 'aar6 '
345 'aar7 ' 'lar0 ' 'lar1 ' 'lar2 ' 'lar3 ' 'lar4 ' 'lar5 '
346 'lar6 ' 'lar7 ' 'lareg ' 'lpl ' 'nar0 ' 'nar1 ' 'nar2 '
347 'nar3 ' 'nar4 ' 'nar5 ' 'nar6 ' 'nar7 ' 'ara0 ' 'ara1 '
348 'ara2 ' 'ara3 ' 'ara4 ' 'ara5 ' 'ara6 ' 'ara7 ' 'arn0 '
349 'arn1 ' 'arn2 ' 'arn3 ' 'arn4 ' 'arn5 ' 'arn6 ' 'arn7 '
350 'sar0 ' 'sar1 ' 'sar2 ' 'sar3 ' 'sar4 ' 'sar5 ' 'sar6 '
351 'sar7 ' 'sareg ' 'spl ' 'a4bd ' 'a6bd ' 'a9bd ' 'abd '
352 'awd ' 's4bd ' 's6bd ' 's9bd ' 'sbd ' 'swd '
353 * ********************************** *
354 'tct ' 'tctr ' 'cmpc ' 'scm ' 'scmr ' 'mlr ' 'mrl '
355 'mvt ' 'csl ' 'csr ' 'sztl ' 'sztr ' 'scd ' 'scdr '
356 'cmpn ' 'mvn ' 'cmpb ' 'btd ' 'dtb ' 'ad2d ' 'sb2d '
357 'mp2d ' 'dv2d ' 'mve ' 'mvne ' 'ad3d ' 'sb3d ' 'mp3d '
358 'dv3d '
359 * ********************************** *
360 'rpd ' 'rpl ' 'rpt '
361 * ********************************** *
362 'stba ' 'stbq ' 'stca ' 'stcq ' ;
363 tagsymb = 'n ' 'au ' 'qu ' 'du ' 'ic ' 'al ' 'ql ' 'dl '
364 'x0 ' 'x1 ' 'x2 ' 'x3 ' 'x4 ' 'x5 ' 'x6 ' 'x7 '
365 'n* ' 'au* ' 'qu* ' 'z23 ' 'ic* ' 'al* ' 'ql* ' 'z27 '
366 'x0* ' 'x1* ' 'x2* ' 'x3* ' 'x4* ' 'x5* ' 'x6* ' 'x7* '
367 'f1 ' 'itp ' 'z42 ' 'its ' 'sd ' 'scr ' 'f2 ' 'f3 '
368 'ci ' 'i ' 'sc ' 'ad ' 'di ' 'dic ' 'id ' 'idc '
369 'z60 ' '*au ' '*qu ' '*du ' '*ic ' '*al ' '*ql ' '*dl '
370 '*x0 ' '*x1 ' '*x2 ' '*x3 ' '*x4 ' '*x5 ' '*x6 ' '*x7 ' ;
371 $OPTIONS compile = security $
372 forbiset = 10 * s1 s0 s3 s0 8 * s2 s0 2 * s3 s2 s0 s3 8 * s2 s3 8 * s2 s3 s1
373 7 * s3 s1 9 * s3 s1 20 * s3 s0 s3 s2 s0 s3 s0 8 * s2 s0 8 * s2
374 11 * s3 3 * s0 s3 s0 s3 * FIXED * s0 8 * s2 s0 8 * s2 10 * s3
375 2 * s0 2 * s2 7 * s0 s3 s0 8 * s2 2 * s0 s3 * FLOAT * s3 s2
376 6 * s3 2 * s2 2 * s3 2 * s2 2 * s3 2 * s2 2 * s3 2 * s2 4 * s0
377 2 * s3 5 * s2 s3 s0 s3 s0 10 * s3 8 * s2 s0 s3 s0 10 * s3 8 * s2
378 s0 s3 s0 10 * s3 8 * s2 s0 s3 * BOOLE * s0 8 * s2 s0 s3 s0
379 8 * s2 * POINT * 75 * s3 * TRANS * 36 * s3 * MISCE * s3 s0 2 * s3
380 7 * s0 2 * s3 s2 s5 * PRIVI * s2 s5 s3 s2 6 * s3 s5 10 * s3
381 s0 5 * s3 s0 * EISSW * 52 * s3 10 * s4 * EISMW * 5 * s0 3 * s2 4 * s3
382 3 * s0 s4 s3 s1 s0 4 * s4 2 * s0 4 * s4 ;
383 $OPTIONS compile = true $
384 codebin =
385 '33A00'x '33C00'x '32000'x '32200'x '32400'x '32600'x '32800'x '32A00'x
386 '32C00'x '32E00'x '1BA00'x '1BE00'x '1BC00'x '1A000'x '1A200'x '1A400'x
387 '1A600'x '1A800'x '1AA00'x '1AC00'x '1AE00'x '13A00'x '03800'x '13E00'x
388 '33800'x '13C00'x '03400'x '12000'x '12200'x '12400'x '12600'x '12800'x
389 '12A00'x '12C00'x '12E00'x '07600'x '3A000'x '3A200'x '3A400'x '3A600'x
390 '3A800'x '3AA00'x '3AC00'x '3AE00'x '3D600'x '3DA00'x '1D800'x '35800'x
391 '3DE00'x '2D800'x '3D000'x '1DE00'x '3D800'x '3DC00'x '25800'x '3C000'x
392 '3C200'x '3C400'x '3C600'x '3C800'x '3CA00'x '3CC00'x '3CE00'x '25000'x
393 '24000'x '24200'x '24400'x '24600'x '24800'x '24A00'x '24C00'x '24E00'x
394 '3FA00'x '3BA00'x '3F200'x '3B200'x '3FE00'x '3BE00'x '3F600'x '3B600'x
395 '3FC00'x '3BC00'x '3F400'x '3B400'x '07A00'x '07E00'x '03600'x '03A00'x
396 '03E00'x '03C00'x '02000'x '02200'x '02400'x '02600'x '02800'x '02A00'x
397 '02C00'x '02E00'x '07C00'x '06000'x '06200'x '06400'x '06600'x '06800'x
398 '06A00'x '06C00'x '06E00'x '05800'x '05A00'x '05C00'x '04000'x '04200'x
399 '04400'x '04600'x '04800'x '04A00'x '04C00'x '04E00'x '07200'x '07400'x
400 '0FA00'x '0FE00'x '0BA00'x '0BE00'x '0BC00'x '0A000'x '0A200'x '0A400'x
401 '0A600'x '0A800'x '0AA00'x '0AC00'x '0AE00'x '0FC00'x '0E000'x '0E200'x
402 '0E400'x '0E600'x '0E800'x '0EA00'x '0EC00'x '0EE00'x '0DA00'x '0DC00'x
403 '0C000'x '0C200'x '0C400'x '0C600'x '0C800'x '0CA00'x '0CC00'x '0CE00'x
404 '0F200'x '0F400'x '20200'x '20400'x '28C00'x '28E00'x '2B200'x '2B600'x
405 '20A00'x '11200'x '09A00'x '09E00'x '09C00'x '08000'x '08200'x '08400'x
406 '08600'x '08800'x '08A00'x '08C00'x '08E00'x '09200'x '13800'x '11800'x
407 '23600'x '23200'x '25E00'x '27400'x '25A00'x '27000'x '27E00'x '23E00'x
408 '27A00'x '23A00'x '2FE00'x '2BE00'x '2FA00'x '2BA00'x '26600'x '22600'x
409 '26200'x '22200'x '2AE00'x '2EE00'x '2AA00'x '2EA00'x '29600'x '2F600'x
410 '27600'x '27200'x '22E00'x '29E00'x '22A00'x '29A00'x '21A00'x '23000'x
411 '21200'x '25C00'x '1FA00'x '1FE00'x '1FC00'x '1DA00'x '1DC00'x '1C000'x
412 '1C200'x '1C400'x '1C600'x '1C800'x '1CA00'x '1CC00'x '1CE00'x '1E000'x
413 '1E200'x '1E400'x '1E600'x '1E800'x '1EA00'x '1EC00'x '1EE00'x '17A00'x
414 '17E00'x '17C00'x '15A00'x '15C00'x '14000'x '14200'x '14400'x '14600'x
415 '14800'x '14A00'x '14C00'x '14E00'x '16000'x '16200'x '16400'x '16600'x
416 '16800'x '16A00'x '16C00'x '16E00'x '37A00'x '37E00'x '37C00'x '35A00'x
417 '35C00'x '34000'x '34200'x '34400'x '34600'x '34800'x '34A00'x '34C00'x
418 '34E00'x '36000'x '36200'x '36400'x '36600'x '36800'x '36A00'x '36C00'x
419 '36E00'x '19A00'x '19E00'x '19C00'x '18000'x '18200'x '18400'x '18600'x
420 '18800'x '18A00'x '18C00'x '18E00'x '11A00'x '11E00'x '11C00'x '10000'x
421 '10200'x '10400'x '10600'x '10800'x '10A00'x '10C00'x '10E00'x '19200'x
422 '19100'x '19600'x '19500'x '1B200'x '1B100'x '1B600'x '1B500'x '19000'x
423 '19300'x '19400'x '19700'x '1B000'x '1B300'x '1B400'x '1B700'x '1D100'x
424 '1D200'x '1D500'x '1D600'x '1F100'x '1F200'x '1F500'x '1F600'x '1D000'x
425 '1D300'x '1D400'x '1D700'x '1F000'x '1F300'x '1F400'x '1F700'x '0F600'x
426 '3E000'x '3E200'x '3E400'x '3E600'x '3E800'x '3EA00'x '3EC00'x '3EE00'x
427 '15100'x '15200'x '15500'x '15600'x '35100'x '35200'x '35500'x '35600'x
428 '15800'x '15000'x '15300'x '15400'x '15700'x '35000'x '35300'x '35400'x
429 '35700'x '2C000'x '2C200'x '2C400'x '2C600'x '2C800'x '2CA00'x '2CC00'x
430 '2CE00'x '05000'x '05200'x '05400'x '05600'x '0D000'x '0D200'x '0D400'x
431 '0D600'x '11600'x '39600'x '33000'x '31000'x '31800'x '31A00'x '30800'x
432 '30900'x '30400'x '30200'x '31E00'x '30A00'x '30B00'x '39000'x '30600'x
433 '30300'x '30100'x '17000'x '17200'x '17400'x '17600'x '37000'x '37200'x
434 '37400'x '37600'x '39A00'x '38000'x '38200'x '38400'x '38600'x '38800'x
435 '38A00'x '38C00'x '38E00'x '30E00'x '30D00'x '30000'x '33600'x '00400'x
436 '39C00'x '39E00'x '00200'x '00800'x '00A00'x '00E00'x '01200'x '01400'x
437 '01600'x '3D900'x '2D000'x '28A00'x '3F800'x '13000'x '37800'x '13400'x
438 '33E00'x '15F00'x '0F700'x '3F900'x '15E00'x '13500'x '31600'x '25400'x
439 '35E00'x '0D800'x '2DF00'x '0D900'x '2DE00'x '15900'x '2B500'x '2B400'x
440 '13600'x '21600'x '13200'x '01A00'x '2D600'x '25200'x '05E00'x '11400'x
441 '31C00'x '2E100'x '2E300'x '2E500'x '2E700'x '2E900'x '2EB00'x '2ED00'x
442 '2EF00'x '3E100'x '3E300'x '3E500'x '3E700'x '3E900'x '3EB00'x '3ED00'x
443 '3EF00'x '26700'x '26F00'x '36100'x '36300'x '36500'x '36700'x '36900'x
444 '36B00'x '36D00'x '36F00'x '2C100'x '2C300'x '2C500'x '2C700'x '2C900'x
445 '2CB00'x '2CD00'x '2CF00'x '34100'x '34300'x '34500'x '34700'x '34900'x
446 '34B00'x '34D00'x '34F00'x '3C100'x '3C300'x '3C500'x '3C700'x '3C900'x
447 '3CB00'x '3CD00'x '3CF00'x '24700'x '24F00'x '28500'x '28300'x '28100'x
448 '28700'x '28F00'x '2A500'x '2A300'x '2A100'x '2A700'x '2AF00'x '0E900'x
449 '0EB00'x '08D00'x '0A900'x '0AB00'x '08100'x '08300'x '0E100'x '06100'x
450 '06300'x '06900'x '06B00'x '0A100'x '0A300'x '18700'x '18100'x '06D00'x
451 '18300'x '18B00'x '10500'x '10700'x '10D00'x '10F00'x '02100'x '02900'x
452 '12500'x '12700'x '12D00'x '12F00'x '2E000'x '28000'x '2A000'x '2D200'x
453 '2D400'x '3D200'x '3D400'x ;
454 valari = 000 016 032 048 064 080 096 112 ;
455 valcar = 16384 08192 00000 ;
456 valpos = 32768 32768 65536 ;
457 valptr = 000000 000128 000256 000384
458 131072 131200 131328 131456 ;
459 valreg = 000000 032768 065536 163840 229376
460 098304 000000 131072 131072 196608 ;
461
462
463 VALSIG = 00000 04096 08192 12288 ;
464 VALABC = 0000 0128 0512 0640 0256 0384 0768 0896 ;
465
466
467
468 prsymb = ' ' 'pr1|' 'pr2|' 'pr5|' 'pr7|' 'pr3|' 'pr0|' 'pr4|' 'pr4|' 'pr6|' ;
469 charsize = '4a ' '6a ' '9a ' $
470
471
472 $OPTIONS page $
473
474 * IMPORTED PROCEDURES FROM RACINE *
475
476 PROCEDURE crealfabox VAR fkonstbox : ctp ; EXTERNAL ;
477 PROCEDURE error errno : integer ; EXTERNAL ;
478 PROCEDURE nextline ; EXTERNAL ;
479 FUNCTION recadre fval fmod : integer : integer ; EXTERNAL ;
480 PROCEDURE statement_begins genp : boolean ; EXTERNAL ;
481 PROCEDURE statement_ends sttlength : integer ; EXTERNAL ;
482
483 * IMPORTED PROCEDURES FROM STATE *
484 PROCEDURE enterundlab VAR fundix : integer ; EXTERNAL ;
485 PROCEDURE gencstecode farg : integer ; finst : istand ; EXTERNAL ;
486 * IMPORTED PROCEDURES FROM CONTEXTTABLE *
487
488 PROCEDURE create_konst_box VAR fvbox : ctp ; fname : alfaid ; ftypofconst : consttype ; EXTERNAL ;
489
490 * IMPORTED FROM PL1 *
491
492 PROCEDURE genreltext relcode : integer ; halfwordcount : integer ; EXTERNAL ;
493
494
495 $OPTIONS page $
496
497
498 $OPTIONS page $
499
500 * ********************************************* GENBINAREA ****************** *
501
502 PROCEDURE genbinarea bytdisp codearea endpoint endcode : integer ;
503 VAR binarea : binartype ;
504 VAR returncode : integer ; EXTERNAL ;
505
506 * C BYTDISP OFFSET IN AREA OF FIRST BYTE TO BE INIT.
507 CODEAREA 1 = TEXT ; 3 = STATICINIT
508 4 = STATICNON INIT
509 ENDPOINT MAX INDEX REACHED IN BINAREA
510 FOR "4" NUMBER OF HALFWORDS
511 ENDCODE LAST RELOCATABLE ITEM TEXT SECTION
512 BINAREA BINARY ITEMS TO BE GENERATED
513 RETURNCODE 0 means OK
514 C *
515
516
517 * ************************************ GENENTRYPOINT PL/1 ***************** *
518
519 PROCEDURE genentrypoint textbytes pr4bytes typofentry : integer ;
520 segname entryname : alfaid ; functionflag : boolean ; VAR entrylength : integer ;
521 VAR returncode : integer ; EXTERNAL ;
522
523 * C .TYPOFENTRY 0 PASCAL INTERNAL PROCEDURE
524 1 PASCAL EXPORTABLE PROCEDURE
525 2 IMPORTED PROCEDURE ===> NO ENTRY SEQUENCE
526 4 EXIT LABEL ===> NO ENTRY SEQUENCE
527 .TEXTBYTES OFFSET IN BYTES IN TEXT SECTION OF ENTRY POINT
528 NO MEANINGS IF TYPOFENTRY=2
529 .PR4BYTES BYTES OFFSET OF AN EVEN-WORD IN LINKAGE SECTION TO BE FILLED
530 WITH AN ITS
531 .SEGNAME 32 CHARS STRING BLANK FOR EXPORTABLE or LOCAL
532 FOUND IN IMPORTSTRING FOR IMPORTED
533 .ENTRYNAME 32 CHARS STRING Pascal name LOCAL or EXPORT
534 FOUND IN IMPORTSTRING
535 .RETURNCODE 0 means OK
536
537 NO MEANING FOR 04
538 C *
539
540
541 * **************************************************** INITGEN ************** *
542
543 PROCEDURE initgen ;
544
545 * C INITIALIZES GENERATION DEPENDANT VARIABLES C *
546 BEGIN
547 $OPTIONS compile = security $
548 forbitag s0 := ;
549 forbitag s1 := tdu tdl ;
550 forbitag s2 := tci tsc tscr ;
551 forbitag s3 := tdu tdl tci tsc tscr ;
552 forbitag s4 := tdu tic tdl tny..tyx7 ;
553 forbitag s5 := tau..tyx7 ;
554 forbiptr s0 := p0t0r1..p1t1r1 ;
555 forbiptr s1 := p0t0r1 p0t1r0 p0t1r1 p1t0r1 p1t1r0 p1t1r1 ;
556 forbiptr s2 := p0t0r1 p0t1r1..p1t1r1 ;
557 forbiptr s3 := p0t0r1 p0t1r1 p1t0r1 p1t1r1 ;
558 forbiptr s4 := ;
559 forbiptr s5 := ;
560 $OPTIONS compile = true $
561 gversion := 00 ;
562 IF gversion > version THEN version := gversion ;
563 indfich := 1 ;
564 ic := 0 ;
565 genetrace := none ;
566 mfreg1 := tn ; mfreg2 := tn ; mfreg3 := tn ; * MOST COMMON USED VALUES *
567 usednameaddr := NIL ;
568 writecode := false ; * TRUE IF 'C' IS '+' *
569 outcode := false ; * OUTPUT OF SYMBOLIQUE ALM CODE *
570 END * INITGEN * ;
571
572
573 $OPTIONS page $
574
575 * *********************************************************FCT LONGINT******** *
576
577 FUNCTION longint fint : integer : integer ;
578
579 * C GIVES THE NUMBER OF DIGITS OF AN INTEGER C *
580 VAR
581 it : integer ;
582 BEGIN
583 IF fint < 0 THEN
584 BEGIN
585 fint := -fint ; it := 1 ;
586 END ELSE
587 it := 0 ;
588 IF fint < 10 THEN it := it + 1 ELSE
589 BEGIN * MORE THAN ONE DIGIT *
590 WHILE fint # 0 DO
591 BEGIN
592 fint := fint DIV 10 ;
593 it := it + 1 ;
594 END ;
595 END ;
596 longint := it ;
597 END * LONGINT * ;
598
599
600
601 $OPTIONS page $
602
603 * ***********************************************WRITEOCTAL ********* *
604
605 PROCEDURE writeoctal fint : integer ;
606
607 * C WRITES FINT IN OCTAL ON 6 CHARACTERS C *
608 VAR
609 bufoct : PACKED ARRAY 1..6 OF char ;
610 it : integer ;
611 BEGIN
612 FOR it := 6 DOWNTO 1 DO
613 BEGIN
614 bufoct it := chr fint MOD 8 + ord '0' ;
615 fint := fint DIV 8 ;
616 END ;
617 write mpcogout bufoct ;
618 END * WRITEOCTAL * ;
619
620
621 $OPTIONS page $
622
623 * *********************************************************GENHALF************ *
624
625 PROCEDURE genhalf fval : integer ;
626
627
628 BEGIN * GENHALF *
629 IF fval < 0 THEN
630 fval := fval + twoto18 ; * TWO'S COMPLEMENT *
631 IF environt = code THEN
632 BEGIN
633 IF outcode THEN
634 BEGIN
635 IF ic MOD bytesinword = 0 THEN
636 BEGIN
637 write mpcogout ' ' : 55 ;
638 writeoctal ic DIV bytesinword ;
639 write mpcogout ' ' ;
640 END ; * FIRST HALF WORD *
641 writeoctal fval ;
642 END ; * OUTCODE *
643 IF codelist THEN
644 IF ic MOD bytesinword = 0 THEN
645 usednamesaddr@ ic DIV bytesinword := usednameaddr ;
646 usednameaddr := NIL ;
647 ic := ic + 2 ; cb := cb + 2 ;
648 END ; * CODE *
649 IF indfich > maxfich THEN
650 BEGIN
651 indfich := 1 ; error 253 ;
652 END ;
653 fichinter^indfich := fval ;
654 indfich := indfich + 1 ;
655 END * GENHALF * ;
656
657
658 $OPTIONS page $
659
660 * ***********************************************INFICH ********************** *
661
662 PROCEDURE infich fval : integer ;
663
664 * C THIS PROCEDURE IS USED TO ADD AN HALF WORD TO FICHINTER VIA GENHALF.
665 IT MUST BE USED TO GENERE EVERYTHING OTHERWISE BY THE ALM GENERATION
666 PROCEDURES C *
667 BEGIN
668 genhalf fval ;
669 IF outcode THEN
670 IF environt = code THEN
671 IF ic MOD bytesinword = 0 THEN nextline ;
672 END * INFICH * ;
673
674
675 $OPTIONS page $
676
677 * *********************************************************GENC*************** *
678
679 PROCEDURE genc fval : integer ;
680
681 * C USED TO GENERE A WORD CSTE. C *
682
683 VAR
684 word : PACKED RECORD
685 CASE boolean OF
686 true : int : integer ;
687 false : high low : shrtint ;
688 END ;
689
690 BEGIN
691 word.int := fval ;
692 infich word.high ;
693 infich word.low ;
694 END * GENC * ;
695
696
697 $OPTIONS page $
698
699 * *********************************************************GENR*************** *
700
701 PROCEDURE genr frval : real ;
702
703 VAR
704 convrec : RECORD
705 CASE boolean OF
706 false : reel : real ;
707 true : left right : integer ;
708 END ;
709 BEGIN * GENR *
710 WITH convrec DO
711 BEGIN
712 reel := frval ;
713 usednameaddr := realformataddr ;
714 genc left ; genc right ;
715 END ;
716 END * GENR * ;
717
718
719 $OPTIONS page $
720
721 * ****************************************************************** ENTERREFTOSYMBOL ************************* *
722
723 FUNCTION enterreftosymbol ctplace : ctp : integer ;
724
725 * C
726 THIS FUNCTION BUILDS THE BACKWARD THREAD OF REFERENCES IN TEXT
727 TO SYMBOL TABLE OF ITEM POINTED BY CTPLACE
728 THESE REFERENCES WILL BE CORRECTLY FILLED IN PASCAL_CREATE_TABLES
729 IF SUCH REFERENCES EXIST SYMBOL TABLE IS GENERATED
730 IF THE OPTION "-TABLE" HAS NOT BEEN GIVEN SYMBOL TABLE WILL ONLY CONTAIN INFORMATION
731 CONCERNING SYMBOLS REFERENCED IN TEXT. C *
732
733 BEGIN
734 WITH ctplace^ DO
735 BEGIN
736 enterreftosymbol := symbtablerefs ;
737 symbtablerefs := ic DIV bytesinword ;
738 END ;
739 selectivetable := true ;
740 END * ENTERREFTOSYMBOL * ;
741
742 $OPTIONS page $
743
744 * **************************** GENMULTICSNIL ******************* *
745
746 PROCEDURE genmulticsnil ;
747
748 BEGIN * GENMULTICSNIL *
749 usednameaddr := nilformataddr ;
750 genc '077777000043'o ;
751 genc '000001000000'o ;
752 END * GENMULTICSNIL * ;
753
754 $OPTIONS page $
755
756 * *********************************************************GENSTRING********** *
757
758 PROCEDURE genstring falfapt : ctp ;
759
760 * C FALFAPT POINTS A BOX KONSTALFACONST C *
761 VAR
762 curalf : alfapt ;
763 h1, it : integer ;
764 BEGIN * GENSTRING *
765 $OPTIONS compile = trace $
766 IF genetrace > none THEN
767 BEGIN
768 write mpcogout '@@@ DEBUT-FIN DE GENSTRING @@@' ;
769 nextline ;
770 END ;
771 $OPTIONS compile = true $
772 curalf := falfapt@.alfadeb ;
773 WHILE curalf # NIL DO
774 WITH curalf@ DO
775 BEGIN
776 it := 1 ;
777 WHILE it < longfill DO
778 BEGIN
779 h1 := ord alfaval it * byteshift + ord alfaval it + 1 ;
780 usednameaddr := asciiformataddr ;
781 infich h1 ;
782 it := it + 2 ;
783 END * LOOP ON THE BOX * ;
784 IF it = longfill THEN * ONE MORE CHAR TO GENERATE *
785 BEGIN
786 usednameaddr := asciiformataddr ;
787 infich ord alfaval it * byteshift ;
788 END ;
789 curalf := nextval ;
790 END ; * LOOP ON THE BOXES *
791 END * GENSTRING * ;
792
793
794 $OPTIONS page $
795
796 * ***********************************************GENALFA********************** *
797
798 PROCEDURE genalfa ;
799
800 * C GENERATION OF AN ALFA STRING IN FICHINTER ; ALFA STRING IS IN
801 BUFVAL on LONGSTRING chars.
802 If LONGSTRING > MAXVAL it is an error due to padding allowed in
803 VALUEDECL.
804 C *
805 * E ERRORS DETECTED
806 209 Too long string
807 E *
808
809 VAR
810 stringpt : integer ;
811 BEGIN
812 $OPTIONS compile = trace $
813 IF genetrace > none THEN
814 BEGIN
815 write mpcogout ' @@@ DEBUT GENALFA @@@ WITH LONGSTRING ' longstring ;
816 nextline ;
817 END ;
818 $OPTIONS compile = true $
819 IF longstring > maxval THEN
820 BEGIN
821 error 209 ; longstring := maxval ;
822 END ;
823 stringpt := 1 ;
824 WHILE stringpt < longstring DO
825 BEGIN
826 usednameaddr := asciiformataddr ;
827 infich ord bufval stringpt * byteshift + ord bufval stringpt + 1 ;
828 stringpt := stringpt + 2 ;
829 END ;
830 IF stringpt = longstring THEN
831 * ONE MORE CHAR ALONE... *
832 BEGIN
833 usednameaddr := asciiformataddr ;
834 infich ord bufval stringpt * byteshift ;
835 END ;
836 IF NOT odd indfich THEN infich 0 ; * PADDING *
837 $OPTIONS compile = trace $
838 IF genetrace > low THEN
839 BEGIN
840 write mpcogout ' @@@ FIN GENALFA @@@ ' ; nextline ;
841 END ;
842 $OPTIONS compile = true $
843 END * GENALFA * ;
844
845
846 $OPTIONS page $
847
848 * ******************************************************** BOUNDSCTRL **** *
849
850 $OPTIONS compile = security $
851 PROCEDURE boundsctrl VAR sfield : integer ; flow fhigh fnoerr : integer ;
852
853 * C CONTROLS THAT SFIELD IS IN FLOW..FHIGH
854 IF NO SFIELD BECOMES ZERO AND ERRORFNOERR IS CALLED. *
855 BEGIN
856 IF sfield > fhigh OR sfield < flow THEN
857 BEGIN
858 sfield := 0 ; error fnoerr ;
859 END ;
860 END * BOUNDSCTRL * ;
861 $OPTIONS compile = true $
862
863
864 $OPTIONS page $
865
866 * ****************************************************** LENGTHCTRL ***** *
867
868 $OPTIONS compile = security $
869 PROCEDURE lengthctrl VAR flength : integer ; fmax : integer ; freg : mreg ;
870
871 * C VERIFICATION OF OPERAND LENGTH IN OPERAND DESCRIPTOR *
872 * E 372 ILLEGAL OPERAND LENGTHLENGTHCTRL
873 374 ILLEGAL MODIFIER LENGTHCTRL *
874 BEGIN
875 IF freg # tn THEN
876 BEGIN
877 fmax := 0 ;
878 IF freg = tdl THEN error 374 ;
879 END ;
880 boundsctrl flength 0 fmax 372 ;
881 END * LENGTHCTRL * ;
882 $OPTIONS compile = true $
883
884
885 $OPTIONS page $
886
887 * ******************************************************** GENWITHPR **** *
888
889 PROCEDURE genwithpr fpr : preg ; fadr : integer ; VAR sbit29 : integer ;
890
891 * C HALF-WORD GENERATION :
892 EITHER ADDRESS 0-17 RETURNS SBIT29 = 000O
893 OR PREG 0-2 AND ADDRESS 3-17 RETURNS SBIT29 = 100O *
894 * E 358 ILLEGAL ADDRESS FIELD WITHOUT PREG GENWITHPR
895 359 ILLEGAL ADDRESS FIELD WITH PREG GENWITHPR *
896 BEGIN
897 IF fpr = nreg THEN * NO POINTER REGISTER *
898 BEGIN
899 $OPTIONS compile = security $
900 boundsctrl fadr -twoto17 twoto18 - 1 358 ;
901 $OPTIONS compile = true $
902 IF fadr < 0 THEN fadr := twoto18 + fadr ; * TWO'S COMPLEMENT *
903 genhalf fadr ;
904 sbit29 := 0 ; * BIT 29 OFF *
905 END ELSE * USE OF POINTER REGISTER *
906 BEGIN
907 $OPTIONS compile = security $
908 IF fpr IN prstatic prlink THEN
909 boundsctrl fadr -twoto14 twoto14 - 1 359 ELSE
910 IF fpr = pr6 THEN
911 boundsctrl fadr -twoto14 twoto14 - 1 390 ELSE
912 boundsctrl fadr -twoto14 twoto14 - 1 391 ;
913 $OPTIONS compile = true $
914 IF fadr < 0 THEN fadr := twoto15 + fadr ; * TWO'S COMPLEMENT *
915 genhalf valreg fpr + fadr ;
916 sbit29 := bit29 ; * BIT 29 ON *
917 END ;
918 END * GENWITHPR * ;
919
920
921 $OPTIONS page $
922
923 * ********************************************************** GENSTAND *** *
924
925 PROCEDURE genstand fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag ;
926
927 * C GENERATION OF A STANDARD INSTRUCTION NOT EIS MULTIWORD STORE BYTES AND
928 CHARACTERS REPETITION *
929 * E 355 : ILLEGAL SHIFT COUNT GENSTAND
930 356 : ILLEGAL INSTRUCTION CODE WITHOUT POINTER REGISTER GENSTAND
931 357 : TAG FIELD IS INCOMPATIBLE WITH INSTRUCTION CODE GENSTAND *
932 LABEL
933 1 ; * IF ILLEGAL CALL *
934 VAR
935 lbit29 : integer ;
936 BEGIN
937 $OPTIONS compile = security $
938 IF fpr = nreg THEN * NO PR *
939 BEGIN
940 IF fcode >= iarl AND fcode <= iqrs AND ftg = tn THEN
941 boundsctrl fadr 0 127 355 ; * SHIFT WITH COUNT IN FADR *
942 IF fcode >= ia4bd THEN error 356 ; * OPERATION ON AREG WITHOUT AREG *
943 END ;
944 $OPTIONS compile = true $
945 IF declarationpart THEN
946 BEGIN
947 illegal_generation := true ;
948 GOTO 1
949 END ;
950 IF ftg IN tdu tdl THEN BEGIN * FIRST HALF WORD *
951 genhalf fadr ;
952 lbit29 := 0
953 END
954 ELSE genwithpr fpr fadr lbit29 ;
955 $OPTIONS compile = security $
956 IF ftg IN forbitag forbiset fcode THEN error 357 ; * ILLEGAL TAG *
957 $OPTIONS compile = true $
958 genhalf codebin fcode + lbit29 + ord ftg ; * SECOND HALF-WORD *
959 IF outcode THEN
960 BEGIN
961 IF fpr = nreg THEN
962 write mpcogout codesymb fcode : 12 fadr : longint fadr
963 ELSE
964 write mpcogout codesymb fcode : 12 prsymb fpr fadr : longint fadr ;
965 IF ftg # tn THEN write mpcogout '' tagsymb ftg ;
966 nextline ;
967 END ;
968 IF fpr = prstatic THEN BEGIN
969 genreltext int15 1 ;
970 genreltext absl 1
971 END
972 ELSE IF fpr = prlink THEN BEGIN
973 genreltext link15 1 ;
974 genreltext absl 1
975 END
976 ELSE genreltext absl 2 ;
977 1 :
978 END * GENSTAND * ;
979
980
981 $OPTIONS page $
982
983 * ********************************************************** GENEISM ***** *
984
985 PROCEDURE geneism fcode : ieism ; ffield : integer ; fbits : zptr ;
986
987 * C GENERATION OF AN EIS MULTIWORD INSTRUCTION. THE MF FIELDS ARE IN THE
988 GLOBAL VARIABLES : MFARI123 AND MFREG123 *
989 * E 367 TAG FORBIDDEN IN EIS MULTIWORD MF GENEISM
990 368 BITS 09 OR 10 ILLEGAL IN EIS GENEISM
991 369 ILLEGAL FIELD 0-8 GENEISM *
992 LABEL
993 1 ; * IF ILLEGAL CALL *
994 VAR
995 lhalf, o1, o2, o3
996 $OPTIONS compile = security $, lhigh
997 $OPTIONS compile = true $
998 : integer ;
999
1000
1001 * *********************************************************OUTMF < GENEISM**** *
1002
1003 PROCEDURE outmf fari : zari ; freg : mreg ;
1004
1005 * C OUTPUT OF A MODIFICATOR FIELD IN AN EIS MULTIWORD C *
1006 VAR
1007 chx : char ;
1008 BEGIN
1009 chx := '' ;
1010 IF fari >= a1r0i0 THEN
1011 BEGIN
1012 write mpcogout chx 'pr' ; chx := '' ;
1013 END ;
1014 IF fari IN a0r1i0 a0r1i1 a1r1i0 a1r1i1 THEN
1015 BEGIN
1016 write mpcogout chx 'rl' ; chx := '' ;
1017 END ;
1018 IF fari IN a0r0i1 a0r1i1 a1r0i1 a1r1i1 THEN
1019 BEGIN
1020 write mpcogout chx 'id' ; chx := '' ;
1021 END ;
1022 IF freg # tn THEN
1023 BEGIN
1024 write mpcogout chx tagsymb freg 1 tagsymb freg 2 ; chx := '' ;
1025 IF tagsymb freg 3 # ' ' THEN write mpcogout tagsymb freg 3 ;
1026 END ;
1027 IF chx = '' THEN write mpcogout '' ELSE write mpcogout '' ;
1028 END * OUTMF * ;
1029
1030
1031 BEGIN * GENEISM *
1032 $OPTIONS compile = security $
1033 IF mfreg1 IN tdu tdl THEN error 367 ;
1034 $OPTIONS compile = true $
1035 IF fcode <= itctr THEN lhalf := 0 ELSE
1036 BEGIN * MORE THAN ONE MF *
1037 IF declarationpart THEN
1038 BEGIN
1039 illegal_generation := true ;
1040 GOTO 1 ;
1041 END ;
1042 $OPTIONS compile = security $
1043 IF mfreg2 IN tdu tdl THEN error 367 ;
1044 IF fbits IN forbiptr forbiset fcode THEN
1045 BEGIN error 368 ; fbits := p0t0r0 END ; * TO AVOID OVERFLOW *
1046 $OPTIONS compile = true $
1047 lhalf := valari mfari2 + ord mfreg2 + valptr fbits ;
1048 IF fcode < imve THEN
1049 BEGIN * TWO MF'S *
1050 $OPTIONS compile = security $
1051 IF fcode <= imvt THEN lhigh := twoto9 - 1 ELSE
1052 IF fcode <= isztr THEN lhigh := 15 ELSE lhigh := 0 ;
1053 boundsctrl ffield 0 lhigh 369 ;
1054 $OPTIONS compile = true $
1055 lhalf := lhalf + ffield * twoto9 ;
1056 END * TWO MF'S * ELSE
1057 BEGIN * THREE MF'S *
1058 $OPTIONS compile = security $
1059 IF mfreg3 IN tdu tdl THEN error 367 ;
1060 $OPTIONS compile = true $
1061 lhalf := lhalf + valari mfari3 + ord mfreg3 * twoto9 ;
1062 END * THREE MF'S * ;
1063 END * MORE THAN ONE MF * ;
1064 genhalf lhalf ; genhalf codebin fcode + valari mfari1 + ord mfreg1 ;
1065 IF outcode THEN
1066 BEGIN
1067 write mpcogout codesymb fcode : 12 ;
1068 outmf mfari1 mfreg1 ;
1069 IF lhalf # 0 THEN
1070 BEGIN
1071 write mpcogout '' ; outmf mfari2 mfreg2 ;
1072 IF fcode >= imvne THEN
1073 BEGIN
1074 write mpcogout '' ; outmf mfari3 mfreg3 ;
1075 END ;
1076 IF fcode < icsl OR fcode > itctr THEN
1077 IF fcode # icmpb THEN
1078 BEGIN
1079 IF fcode = iscm OR fcode = iscmr THEN write mpcogout 'MASK' ELSE
1080 IF fcode < icsl THEN write mpcogout 'fill' ELSE
1081 write mpcogout 'bool' ;
1082 o1 := ffield DIV 64 ;
1083 o2 := ffield - o1 * 64 DIV 8 ;
1084 o3 := ffield MOD 8 ;
1085 write mpcogout o1 : 1 o2 : 1 o3 : 1 '' ;
1086 END ;
1087 IF fbits IN p0t1r0 p0t1r1 p1t1r0 p1t1r1 THEN
1088 write mpcogout 'enablefault' ;
1089 IF fbits IN p0t0r1 p0t1r1 p1t0r1 p1t1r1 THEN write mpcogout 'round' ;
1090 IF fcode = icmpb OR fcode <= isztr AND fcode >= icsl THEN
1091 IF fbits >= p1t0r0 THEN write mpcogout 'fill1'
1092 ELSE write mpcogout 'fill0' ;
1093 END ;
1094 nextline ;
1095 END ;
1096 mfreg1 := tn ; mfreg2 := tn ; mfreg3 := tn ; * MOST COMMON VALUES *
1097 genreltext absl 2 ;
1098 1 :
1099 END * GENEISM * ;
1100
1101
1102 $OPTIONS page $
1103
1104 * ************************************************************* GENREPT *** *
1105
1106
1107 PROCEDURE GENREPTFTALLY:INTEGER;FABC:ZABC;FCODE:IREPT;
1108 FTERCONDFDELTA : INTEGER;
1109
1110 CC*C GENERATION OF A REPEAT INSTRUCTION *
1111 EE*E 361 ILLEGAL TALLY GENREPT
1112 362 ILLEGAL TERMINATION CONDITION GENREPT
1113 363 ILLEGAL DELTA GENREPT
1114 364 BITS 8910 INCOMPATIBLE WITH INSTRUCTION CODE GENREPT *
1115 GGBEGIN
1116 / BOUNDSCTRLFTALLY0255361; BOUNDSCTRLFTERCOND0127362 ;
1117 IF FCODE=IRPL THEN
1118 BEGIN
1119 IF FABC>A0B0C1 OR FDELTA#0 THEN ERROR364;
1120 END ELSE
1121 BEGIN
1122 BOUNDSCTRLFDELTA063363;
1123 IF FCODE=IRPT AND FABC>A1B0C1 THEN ERROR364;
1124 END ; /
1125 GENHALFFTALLY*TWOTO10+VALABCFABC+FTERCOND;
1126 GENHALFCODEBINFCODE+INHIBIT+FDELTA ;
1127 IF OUTCODE THEN NEXTLINE;
1128 DDEND * GENREPT * ;
1129
1130
1131 $OPTIONS page $
1132
1133 * *********************************************************** GENSTOBC *** *
1134
1135 PROCEDURE GENSTOBCFPR:PREG;FADR:INTEGER;FCODE:ISTOBC;FPOS:INTEGER;
1136
1137 CC*C GENERATION OF A STORE BYTES OR CHARACTERS INSTRUCTION
1138 FPOS GIVES THE BYTES OR CHARACTERS TO BE STORED *
1139 EE*E 360 ILLEGAL TAG FIELD FOR BYTES'POSITION GENSTOBC *
1140 RRVAR
1141 LBIT29 : INTEGER ;
1142 GGBEGIN
1143 GENWITHPRFPRFADRLBIT29;
1144 / BOUNDSCTRLFPOS063360;
1145 IF FCODE < ISTCA AND FPOS MOD 4 # 0 THEN ERROR360; /
1146 GENHALFCODEBINFCODE+LBIT29+FPOS;
1147 IF OUTCODE THEN
1148 BEGIN
1149 WRITEMPCOGOUTCODESYMBFCODE:12PRSYMBFPRFADR:LONGINTFADR'O';
1150 WRITEMPCOGOUTFPOS DIV 8:1FPOS MOD 8:1;
1151 NEXTLINE;
1152 END;
1153 DDEND * GENSTOBC *;
1154
1155
1156 $OPTIONS page $
1157
1158 * ************************************************************ GENDESCA *** *
1159
1160 PROCEDURE gendesca fareg : preg ; fadr fcn : integer ; fta : lgcar ; fn : integer ;
1161 frlgth : mreg ;
1162
1163 * C GENERATION OF AN ALPHANUMERIC OPERAND DESCRIPTOR *
1164 * E 373 ILLEGAL CHARACTERS COUNT GENDESC *
1165 VAR
1166 ldummy
1167 $OPTIONS compile = security $ lhigh
1168 $OPTIONS compile = true $
1169 : integer ;
1170 BEGIN
1171 genwithpr fareg fadr ldummy ;
1172 $OPTIONS compile = security $
1173 lengthctrl fn twoto12 - 1 frlgth ; * OPERAND LENGTH *
1174 CASE fta OF
1175 l9 : lhigh := 3 ;
1176 l6 : lhigh := 5 ;
1177 l4 : lhigh := 7 ;
1178 END * CASE * ; boundsctrl fcn 0 lhigh 373 ;
1179 $OPTIONS compile = true $
1180 genhalf fcn * valpos fta + valcar fta + fn + ord frlgth ;
1181 IF outcode THEN
1182 BEGIN
1183 IF fareg = nreg THEN
1184 write mpcogout 'desc' : 8 charsize fta fadr : longint fadr
1185 ELSE
1186 write mpcogout 'desc' : 8 charsize fta prsymb fareg fadr : longint fadr ;
1187 IF fcn # 0 THEN write mpcogout '' fcn : longint fcn '' ;
1188 IF frlgth = tn THEN write mpcogout '' fn : longint fn ELSE
1189 write mpcogout '' tagsymb frlgth ;
1190 nextline ;
1191 END ;
1192 IF fareg = prstatic THEN BEGIN
1193 genreltext int15 1 ;
1194 genreltext absl 1
1195 END
1196 ELSE IF fareg = prlink THEN BEGIN
1197 genreltext link15 1 ;
1198 genreltext absl 1
1199 END
1200 ELSE genreltext absl 2 ;
1201 END * GENDESCA * ;
1202
1203
1204 $OPTIONS page $
1205
1206 * *********************************************************** GENDESCN *** *
1207
1208 PROCEDURE GENDESCNFAREG:PREG;FADRFCN:INTEGER;FTN:LGCAR;FS:TYPSIG;
1209 FSFFN:INTEGER;FRLGTH:MREG;
1210
1211 CC*C GENERATION OF A NUMERIC OPERAND DESCRIPTOR *
1212 EE*E 373 ILLEGAL CHARACTERS COUNT GENDESC
1213 376 ILLEGAL SCALING FACTORGENDESCN *
1214 RRVAR
1215 LDUMMY /LHIGH/ : INTEGER;
1216 GGBEGIN
1217 GENWITHPRFAREGFADRLDUMMY;
1218 / LENGTHCTRLFN63FRLGTH; * OPERAND LENGTH *
1219 BOUNDSCTRLFSF-3231376;
1220 CASE FTN OF
1221 L9 : LHIGH:=3 ;
1222 L4 : LHIGH:=7 ;
1223 L6 : BEGIN
1224 LHIGH := -1; * TO FORCE AN ERROR *
1225 FTN := L9; * TO HAVE A RELEVANT FIELD => NO OVERFLOW *
1226 END ; * L6 *
1227 END * CASE *;
1228 BOUNDSCTRLFCN0LHIGH373; /
1229 IF FSF<0 THEN FSF:=64+FSF; * TWO'S COMPLEMENT *
1230 GENHALFFCN*VALPOSFTN+VALCARFTN+VALSIGFS+FSF*TWOTO6+FN+ORDFRLGTH;
1231 IF OUTCODE THEN NEXTLINE;
1232 DDEND * GENDESCN * ;
1233
1234
1235 $OPTIONS page $
1236
1237 * ************************************************************ GENDESCB *** *
1238
1239 PROCEDURE gendescb fareg : preg ; fadr fc fb fn : integer ; frlgth : mreg ;
1240
1241 * C GENERATION OF A BITS STRING OPERAND DESCRIPTOR *
1242 * E 373 ILLEGAL CHARACTERS COUNTGENDESC
1243 375 ILLEGAL BITS COUNTGENDESCB *
1244 VAR
1245 ldummy : integer ;
1246 BEGIN
1247 genwithpr fareg fadr ldummy ;
1248 $OPTIONS compile = security $
1249 lengthctrl fn twoto12 - 1 frlgth ; * OPERAND LENGTH *
1250 boundsctrl fc 0 63 373 ; boundsctrl fb 0 8 375 ;
1251 $OPTIONS compile = true $
1252 genhalf fc * twoto16 + fb * twoto12 + fn + ord frlgth ;
1253 IF outcode THEN
1254 BEGIN
1255 IF fareg = nreg THEN
1256 write mpcogout ' descb ' fadr : longint fadr
1257 ELSE
1258 write mpcogout ' descb ' prsymb fareg fadr : longint fadr ;
1259 ldummy := 3 * fc + fb ;
1260 IF ldummy # 0 THEN write mpcogout '' ldummy : longint ldummy '' ;
1261 IF frlgth = tn THEN write mpcogout '' fn : longint fn ELSE
1262 write mpcogout '' tagsymb frlgth ;
1263 nextline ;
1264 END ;
1265 IF fareg = prstatic THEN BEGIN
1266 genreltext int15 1 ;
1267 genreltext absl 1
1268 END
1269 ELSE IF fareg = prlink THEN BEGIN
1270 genreltext link15 1 ;
1271 genreltext absl 1
1272 END
1273 ELSE genreltext absl 2 ;
1274 END * GENDESCB * ;
1275
1276
1277 $OPTIONS page $
1278
1279 * ************************************************************* GENINDW **** *
1280
1281 PROCEDURE GENINDWFPR:PREG;FADR:INTEGER;FTG:TAG;EIS:BOOLEAN;
1282
1283 CC*C GENERATION OF AN INDIRECT WORDTO DESCRIPTOR IF EIS=TRUE *
1284 EE*E 370 ILLEGAL TAG IN AN INDIRECT WORD GENINDW
1285 371 USE OF PREG NOT ALLOWED IN AN INDIRECT WORD GENINDW *
1286 RRVAR
1287 LBIT29 : INTEGER;
1288 GGBEGIN
1289 GENWITHPRFPRFADRLBIT29;
1290 / IF EIS THEN
1291 BEGIN
1292 IF NOT FTG IN TN..TQUTIC..TQLTX0..TX7 THEN ERROR370;
1293 END ELSE
1294 BEGIN * NOT EIS *
1295 IF FTG IN TITPTITS THEN ERROR370;
1296 IF LBIT29 # 0 THEN ERROR371; * PREG NOT ALLOWED *
1297 END; /
1298 GENHALFORDFTG+LBIT29;
1299 IF OUTCODE THEN
1300 BEGIN
1301 WRITEMPCOGOUT' VFD ';
1302 IF FPR#NREG THEN WRITEMPCOGOUT'3/'ORDFPR:1'15/' ELSE
1303 WRITEMPCOGOUT'18/'FADR:LONGINTFADR'11/01/';
1304 IF FPR#NREG THEN WRITEMPCOGOUT'1' ELSE WRITEMPCOGOUT'0';
1305 WRITEMPCOGOUT'O6/'ORDFTG DIV 8:1ORDFTG MOD 8:1;
1306 NEXTLINE;
1307 END;
1308 DDEND * GENINDW * ;
1309
1310
1311 $OPTIONS page $
1312
1313 * *********************************************************** GENINDIT **** *
1314
1315 PROCEDURE GENINDITFADRFTALLYFTG : INTEGER;
1316
1317 CC*C GENERATION OF AN INDIRECT WORD WITH THREE BINARY FIELDS
1318 0-17=FADR ; 18-29=FTALLY;30-35=FTG *
1319 EE*E 377 ILLEGAL TALLY OR TAG GENINDIT *
1320 RRVAR
1321 LDUMMY : INTEGER ;
1322 GGBEGIN
1323 GENWITHPRNREGFADRLDUMMY;
1324 / BOUNDSCTRLFTALLY0TWOTO12-1377;
1325 BOUNDSCTRLFTG063377; /
1326 GENHALF FTALLY*TWOTO6+FTG;
1327 IF OUTCODE THEN NEXTLINE;
1328 DDEND * GENINDIT *;
1329
1330
1331 $OPTIONS page $
1332
1333 * ************************************************************ GENIPAIR ***** *
1334
1335 PROCEDURE GENIPAIRFPR:PREG;FSNOFWNOFBNO:INTEGER;FTG:TAG;
1336
1337 CC*C GENERATION OF AN ITS OR ITP WORDS PAIR *
1338 EE*E 365 ILLEGAL SEGMENT NUMBER GENIPAIR
1339 366 ILLEGAL SECOND WORD IN AN ITP OR ITS GENIPAIR
1340 $$*$PAGE*
1341 E*
1342 RRVAR
1343 LTAGLDUMMY : INTEGER;
1344 GGBEGIN
1345 IF FPR # NREG THEN
1346 BEGIN * ITP *
1347 GENHALFVALREGFPR;LTAG:=O41;
1348 END ELSE
1349 BEGIN * ITS *
1350 / BOUNDSCTRLFSNO0TWOTO15-1365; /
1351 GENHALFFSNO;LTAG:=O43;
1352 END;
1353 GENHALFLTAG;
1354 IF OUTCODE THEN
1355 BEGIN
1356 IF FPR#NREG THEN WRITEMPCOGOUT' ITP 'PRSYMBFPR ELSE
1357 WRITEMPCOGOUT' ITS 'FSNO:LONGINTFSNO'';
1358 WRITEMPCOGOUTFWNO:LONGINTFWNO''TAGSYMBFTG;
1359 NEXTLINE;
1360 END;
1361 GENWITHPRNREGFWNOLDUMMY;
1362 / BOUNDSCTRLFBNO035366; IF FTG INTITPTITS THEN ERROR366; /
1363 GENHALFFBNO*TWOTO9+ORDFTG;
1364 IF OUTCODE THEN NEXTLINE ;
1365 DDEND * GENIPAIR *;
1366
1367
1368 $OPTIONS page $
1369
1370 * ************************************ INSER ********************************* *
1371
1372 PROCEDURE inser fcb fplace : integer ;
1373
1374 * C "FPLACE" IS AN INDEX ON FICHINTER OF INCOMPLETE INSTRUCTION.
1375 FICHINTER : ARRAY 1.. OF SHRTINT;
1376 CB CODE COUNTER 0 FOR THE FIRST INST IN THE PROC
1377 C *
1378 * E ERRORS DETECTED
1379 408: GIVEN FPLACE OUT OF RANGE
1380 409: COMPUTED DISP OUT OF RANGE
1381 410: NON-ZERO DISPLACEMENT PART.
1382 E *
1383 LABEL
1384 1 ; * SKIP IF ILLEGAL CALL *
1385
1386 VAR
1387 coddep : integer ;
1388 lerr : boolean ;
1389 BEGIN
1390 IF declarationpart THEN
1391 BEGIN
1392 illegal_generation := true ;
1393 GOTO 1
1394 END ;
1395 lerr := false ;
1396 * A CODE DISP MUST BE EXPRESSED IN WORDS *
1397 coddep := fcb * BYTES FROM 0 * - 2 * fplace - 1 DIV bytesinword ;
1398 $OPTIONS compile = security $
1399 * AUTO-CONTROLE *
1400 lerr := true ;
1401 IF fplace < 1 OR fplace > maxfich THEN error 408 ELSE
1402 IF coddep < -twoto17 OR coddep > twoto17 - 1 THEN error 409 ELSE
1403 IF fichinter^fplace # 0 THEN error 410 ELSE lerr := false ;
1404 $OPTIONS compile = true $
1405 IF outcode THEN
1406 BEGIN
1407 write mpcogout '@@@' '*' : 80 'INSER ' coddep : 6 ' AT ' ;
1408 writeoctal ic - cb - fplace * 2 DIV bytesinword ;
1409 nextline ;
1410 END ;
1411 IF NOT lerr THEN fichinter^fplace := coddep ;
1412 1 :
1413 END * INSER * ;
1414
1415
1416 $OPTIONS page $
1417
1418 * ************************************ GENINSERTION ************************** *
1419
1420 PROCEDURE geninsertion fplace : integer ; fptproc : ctp ;
1421
1422 * C .IN ENTRY SEQUENCE AN INCOMPLETE INSTRUCTION HAS BEEN
1423 GENERATED FOR THE CURRENT STACK FRAME SIZE;
1424 .FPLACE IS THE FICHINTER INDEX OF THIS INSTRUCTION.
1425 .AT END OF PROC TMAX IS THE LARGEST DISPLACEMENT IN CURRENT STACKFRAME
1426 AND MUST BE INSERTED IN INCOMPLETE INSTR.
1427 C *
1428 * E ERRORS DETECTED
1429 214 : STACK FRAME MUST NOT EXCCEED MAXSTACKSIZE BYTES
1430 E *
1431 VAR
1432 coddep : integer ;
1433 BEGIN
1434 $OPTIONS compile = trace $
1435 IF genetrace > none THEN
1436 BEGIN
1437 write mpcogout '@@@ DEBUT-FIN GENINSERTION @@@ WITH FPLACE TMAX' fplace tmax ;
1438 nextline ;
1439 END ;
1440 $OPTIONS compile = true $
1441 tmax := recadre tmax stackboundary ;
1442 IF tmax >= maxstacksize THEN
1443 error 213 ELSE
1444 BEGIN
1445 coddep := tmax DIV bytesinword ;
1446 IF outcode THEN
1447 BEGIN
1448 write mpcogout '@@@' '*' : 80 'INSER ' coddep : 6 ' AT ' ;
1449 writeoctal ic - cb - fplace * 2 DIV bytesinword ;
1450 nextline ;
1451 END ;
1452 fichinter^fplace := coddep ;
1453 END ;
1454 END * GENINSERTION * ;
1455
1456
1457 $OPTIONS page $
1458
1459 * ************************************ GENCODFONCT *************************** *
1460
1461 PROCEDURE gencodfonct fptproc : ctp ;
1462
1463 * C .CALLED AT END OF GENERATED CODE FOR A FUNCTION.
1464 .LOADS* A SCALARNUMERIC *
1465 * AQ POINTER * WITH THE VALUE STORED IN PR6|FCTDEPLW
1466 *EAQ REAL *
1467 .STORES ALSO THIS VALUE IN STORAGE POINTED BY THE LAST "ITS" OF THE
1468 ARGUMENT LIST MOVED AT DEBSTACKLOCAL BY GENPRCENTRY
1469 .THE RETURN-OPERATOR DOES NOT ALTER EAQ
1470 .FPTPROC IS NOT NIL TESTED BEFORE CALL AND POINTS THE BOX "PROC"
1471 C *
1472 VAR
1473 lload lstor : istand ;
1474 fctitsw : integer ;
1475 BEGIN * GENCODFONCT *
1476 $OPTIONS compile = trace $
1477 IF genetrace > none THEN
1478 BEGIN
1479 write mpcogout '@@@ DEBUT GENCODFONCT @@@' ; nextline ;
1480 END ;
1481 $OPTIONS compile = true $
1482 WITH fptproc@ DO
1483 IF proctype # NIL THEN
1484 BEGIN * NO TYPE ERROR *
1485 IF proctype@.form = reel THEN
1486 BEGIN lload := idfld ; lstor := idfst ;
1487 END ELSE
1488 IF proctype@.form = pointer THEN
1489 BEGIN lload := ildaq ; lstor := istaq ;
1490 END ELSE
1491 BEGIN lload := ilda ; lstor := ista ;
1492 END ;
1493 fctitsw := pascdebstacklocal + nbparproc - 1 * bytesindword DIV bytesinword ;
1494 * LOAD REG *
1495 usednameaddr := fptproc ;
1496 genstand pr6 fctdeplw lload tn ;
1497 * STORE VALUE *
1498 genstand pr6 fctitsw lstor tny ;
1499 END * #NIL WITH * ;
1500 $OPTIONS compile = trace $
1501 IF genetrace > none THEN
1502 BEGIN
1503 write mpcogout '@@@ FIN GENCODFONCT @@@' ; nextline ;
1504 END ;
1505 $OPTIONS compile = true $
1506 END * GENCODFONCT * ;
1507
1508
1509 $OPTIONS page $
1510
1511 * ********************************************* LONGPROFILEENTRYSEQUENCE ***************************** *
1512
1513 PROCEDURE longprofileentrysequence ;
1514
1515 VAR
1516 lbit29 : integer ;
1517
1518 BEGIN
1519 genwithpr pr0 longprofileplace lbit29 ;
1520 genhalf codebin itsp3 + lbit29 + ord tn ;
1521 IF outcode THEN
1522 BEGIN
1523 write mpcogout codesymb itsp3 : 12 prsymb pr0 longprofileplace : longint longprofileplace ;
1524 nextline
1525 END ;
1526 usednameaddr := octalformataddr ;
1527 genhalf 0 ;
1528 genhalf 5 ;
1529 IF outcode THEN nextline ;
1530 genreltext absl 2 ;
1531 genreltext prof 1 ;
1532 genreltext absl 1 ;
1533 genwithpr pr0 longprofileplace lbit29 ;
1534 genhalf codebin itsp3 + lbit29 + ord tn ;
1535 IF outcode THEN
1536 BEGIN
1537 write mpcogout codesymb itsp3 : 12 prsymb pr0 longprofileplace : longint longprofileplace ;
1538 nextline
1539 END ;
1540 usednameaddr := octalformataddr ;
1541 genhalf 0 ;
1542 genhalf 5 ;
1543 IF outcode THEN nextline ;
1544 genreltext absl 2 ;
1545 genreltext prof 1 ;
1546 genreltext absl 1 ;
1547 genwithpr pr0 longprofileplace lbit29 ;
1548 genhalf codebin itsp3 + lbit29 + ord tn ;
1549 IF outcode THEN
1550 BEGIN
1551 write mpcogout codesymb itsp3 : 12 prsymb pr0 longprofileplace : longint longprofileplace ;
1552 nextline
1553 END ;
1554 usednameaddr := octalformataddr ;
1555 genhalf 0 ;
1556 genhalf 9 ;
1557 IF outcode THEN nextline ;
1558 genreltext absl 2 ;
1559 genreltext prof 1 ;
1560 genreltext absl 1 ;
1561 genwithpr pr0 longprofileplace lbit29 ;
1562 genhalf codebin itsp3 + lbit29 + ord tn ;
1563 IF outcode THEN
1564 BEGIN
1565 write mpcogout codesymb itsp3 : 12 prsymb pr0 longprofileplace : longint longprofileplace ;
1566 nextline
1567 END ;
1568 usednameaddr := octalformataddr ;
1569 genhalf 0 ;
1570 genhalf 9 ;
1571 IF outcode THEN nextline ;
1572 genreltext absl 2 ;
1573 genreltext prof 1 ;
1574 genreltext absl 1 ;
1575 genwithpr pr0 longprofileplace lbit29 ;
1576 genhalf codebin itsp3 + lbit29 + ord tn ;
1577 IF outcode THEN
1578 BEGIN
1579 write mpcogout codesymb itsp3 : 12 prsymb pr0 longprofileplace : longint longprofileplace ;
1580 nextline
1581 END ;
1582 usednameaddr := octalformataddr ;
1583 genhalf 0 ;
1584 genhalf 5 ;
1585 IF outcode THEN nextline ;
1586 genreltext absl 2 ;
1587 genreltext prof 1 ;
1588 genreltext absl 1 ;
1589
1590 END ;
1591
1592 $OPTIONS page $
1593
1594 * ********************************************** GENPROFILEREF ************************************ *
1595
1596 PROCEDURE genprofileref ;
1597
1598 * C GENERATES INSTRUCTION AOS 4|N TO INCREMENT PROFILE COUNTER C *
1599
1600 VAR
1601 lbit29 : integer ;
1602 counterplace : integer ;
1603
1604 BEGIN
1605 counterplace := profilewordcount + 1 ;
1606 genwithpr prstatic counterplace lbit29 ;
1607 genhalf codebin iaos + lbit29 + ord tn ;
1608 IF outcode THEN BEGIN
1609 write mpcogout codesymb iaos : 12 prsymb prstatic counterplace : longint counterplace ;
1610 nextline
1611 END ;
1612 insert_ statnbr * 2 18 profptr^profilewordcount ;
1613 profilewordcount := profilewordcount + pclength ;
1614 genreltext prof 1 ;
1615 genreltext absl 1 ;
1616 END ;
1617
1618 $OPTIONS page $
1619
1620 * *************************************************** GENLONGPROFILEREF *************************** *
1621
1622 PROCEDURE genlongprofileref ;
1623
1624 * C GENERATES CALL TO LONG_PROFILE OPERATOR TO INCREMENT LONG_PROFILE COUNTERS C *
1625
1626 VAR
1627 lbit29 : integer ;
1628
1629 BEGIN
1630 genwithpr pr0 longprofileplace lbit29 ;
1631 genhalf codebin itsp3 + lbit29 + ord tn ;
1632 IF outcode THEN
1633 BEGIN
1634 write mpcogout codesymb itsp3 : 12 prsymb pr0 longprofileplace : longint longprofileplace ;
1635 nextline
1636 END ;
1637 usednameaddr := octalformataddr ;
1638 genhalf 0 ;
1639 genhalf profilewordcount ;
1640 insert_ statnbr * 2 18 profptr^profilewordcount ;
1641 profilewordcount := profilewordcount + lpclength ;
1642 IF outcode THEN nextline ;
1643 genreltext absl 2 ;
1644 genreltext prof 1 ;
1645 genreltext absl 1 ;
1646 END ;
1647
1648 $OPTIONS page $
1649
1650 * ********************************* GENENTRYSTRUCTURE ************************************************************** *
1651
1652 PROCEDURE genentrystructure ;
1653
1654 * C GENERATES A TWO WORDS STRUCTURE AFTER THE CALL TO THE ENTRY OPERATOR
1655 THIS STRUCTURE CONTAINS OFFSET TO LINK TO SYMBOL TABLE
1656 AND OFFSET IN SYMBOL SECTION OF SYMBOL BLOCK OF PROCEDURE.
1657 THIS STRUCTURE IS FILLED LATER BY pascal_create_tables_ C *
1658
1659 BEGIN
1660 currentnode^.structureplace := ic DIV bytesinword ;
1661 usednameaddr := octalformataddr ;
1662 genc 0 ;
1663 usednameaddr := octalformataddr ;
1664 genc 0 ;
1665 genreltext absl 2 ;
1666 IF symbtabl THEN
1667 BEGIN
1668 genreltext link18 1 ;
1669 genreltext symb 1 ;
1670 END
1671 ELSE
1672 genreltext absl 2 ;
1673 END * GENENTRYSTRUCTURE * ;
1674
1675 $OPTIONS page $
1676
1677 * ************************************ EXITLABEL ***************************** *
1678
1679 PROCEDURE exitlabel flabinx : integer ; flabplace : integer ;
1680
1681 * C FLABINX IS BYTES DISPLACEMENT IN LINKAGE SECTION OF AN ITSWHICH MUST
1682 POINT AT EXECUTION TIME ON THE INSTRUCTION AT DISPLACEMENT
1683 FLABPLACE IN TEXT SECTION
1684 C *
1685 VAR
1686 locreturncode entrylength : integer ;
1687 functionflag : boolean ;
1688 BEGIN * EXITLABEL *
1689 $OPTIONS compile = trace $
1690 IF genetrace > none THEN
1691 BEGIN
1692 write mpcogout
1693 '@@@ DEBUT EXITLABEL @@@ WITH FLABINXFLABPLACE' flabinx flabplace ;
1694 nextline ;
1695 END ;
1696 $OPTIONS compile = true $
1697 IF errtotal = 0 THEN
1698 BEGIN
1699 functionflag := false ;
1700 genentrypoint flabplace flabinx
1701 4 * EXIT LABEL *
1702 blank blank
1703 functionflag
1704 entrylength
1705 locreturncode ;
1706 IF locreturncode <> 0 THEN
1707 error 500 ;
1708 END ;
1709 $OPTIONS compile = trace $
1710 IF genetrace > low THEN
1711 BEGIN
1712 write mpcogout '@@@ FIN EXITLABEL @@@' ; nextline ;
1713 END ;
1714 $OPTIONS compile = true $
1715 END * EXITLABEL * ;
1716
1717
1718 $OPTIONS page $
1719
1720 * ************************************ GENPROLOG ***************************** *
1721
1722 PROCEDURE genprolog VAR unres : integer ; VAR fdebic : integer ;
1723
1724 * C .CALLED TO GENERATE THE CALL OF " MAIN-ENTRY-OPERATOR"
1725 .CONTEXT IS
1726 PR6 =FRAME CALLER PR7 STACK HEADER
1727 .AFTER MAIN ENTRY
1728 PR6 FRAME MAIN
1729 PR0 PASCAL OPERATOR
1730 PR4 LINKAGE SECTION OF PROGRAM
1731 .CALL RESET REWRITE FOR INPUTOUTPUT
1732 C *
1733 VAR
1734 functionflag : boolean ;
1735 it execflags locreturncode entrylength : integer ;
1736 BEGIN * GENPROLOG *
1737 $OPTIONS compile = trace $
1738 IF genetrace > none THEN
1739 BEGIN
1740 write mpcogout '@@@ DEBUT GENPROLOG @@@ WITH FDEBIC' fdebic ; nextline ;
1741 END ;
1742 $OPTIONS compile = true $
1743 * *
1744 * FIRST CALL PL1 PROCEDURE *
1745 * TO GENERATE ENTRY POINT SEQUENCE *
1746 * *
1747 functionflag := false ;
1748 entrylength := 0 ;
1749 IF errtotal = 0 THEN
1750 BEGIN
1751 genentrypoint fdebic 0 * NO MEANING *
1752 3 * MAIN ENTRY POINT *
1753 blank * For segname *
1754 progname * For entryname *
1755 functionflag
1756 entrylength
1757 locreturncode ;
1758 IF locreturncode <> 0 THEN
1759 error 501 ;
1760 END ;
1761 * INCR IC *
1762 fdebic := fdebic + entrylength ;
1763 IF codelist THEN
1764 FOR it := ic TO ic + entrylength - 1 DO
1765 IF it MOD bytesinword = 0 THEN
1766 BEGIN
1767 usednamesaddr@ it DIV bytesinword := octalformataddr ;
1768 usednameaddr := NIL ;
1769 END ;
1770 ic := ic + entrylength ;
1771 mainloc := ic DIV bytesinword ;
1772 IF linktomain THEN
1773 IF errtotal = 0 THEN
1774 BEGIN
1775 genentrypoint ic linktomainplace 0 blank blank functionflag entrylength locreturncode ;
1776 IF locreturncode <> 0 THEN
1777 error 502 ;
1778 END ;
1779 genstand nreg 0 iepp5 tic ; * OFFSET OF 1RST INSTR OF MAIN *
1780 genstand pr7 transoptvptr iepp2 tny ; * PTR ON OP SEG'S TRANSFER VECTORS *
1781 genstand pr2 pascoperatorsdep iepp2 tny ; * PASCAL OPERATORS SEGMENT *
1782 execflags := mainbit ;
1783 IF fastoperator THEN
1784 execflags := execflags + fastbit ;
1785 IF asscheck THEN execflags := execflags + checkbit ;
1786 IF interactive THEN execflags := execflags + interactivebit ;
1787 IF envstandard = stdsol THEN execflags := execflags + solstandardbit ;
1788 IF iowarnings THEN execflags := execflags + iowarningsbit ;
1789 genstand nreg execflags ildq tdl ;
1790 unres := indfich ; genstand nreg 0 ieax7 tn ; * FILLED LATER *
1791 genstand pr2 mainentryplace itsp3 tn ;
1792 genentrystructure ;
1793 IF mapswitch THEN BEGIN
1794 IF longprofile THEN longprofileentrysequence ;
1795 statement_ends currentnode^.hdrlen ;
1796 statement_begins true ;
1797 END ;
1798 IF inputctp # NIL THEN
1799 BEGIN
1800 usednameaddr := inputctp ;
1801 genstand prlink inputctp@.vaddr DIV bytesinword iepp3 tny ;
1802 genstand pr6 fsbadrw ispri3 tn ;
1803 genstand pr0 resetplace itsp3 tn ;
1804 END ;
1805 IF outputctp # NIL THEN
1806 BEGIN
1807 usednameaddr := outputctp ;
1808 genstand prlink outputctp@.vaddr DIV bytesinword iepp3 tny ;
1809 genstand pr6 fsbadrw ispri3 tn ;
1810 genstand pr0 rewriteplace itsp3 tn ;
1811 END ;
1812 IF errorctp <> NIL THEN
1813 BEGIN
1814 usednameaddr := errorctp ;
1815 genstand prlink errorctp^.vaddr DIV bytesinword iepp3 tny ;
1816 genstand pr6 fsbadrw ispri3 tn ;
1817 genstand pr0 rewriteplace itsp3 tn ;
1818 END ;
1819
1820 $OPTIONS compile = trace $
1821 IF genetrace > low THEN
1822 BEGIN
1823 write mpcogout '@@@ FIN GENPROLOG @@@' ; nextline ;
1824 END ;
1825 $OPTIONS compile = true $
1826 END * GENPROLOG * ;
1827
1828
1829 $OPTIONS page $
1830
1831 * ************************************ GENPGEXIT ***************************** *
1832
1833 PROCEDURE genpgexit ;
1834
1835 * C GENERATES THE CALL OF MAIN-RETURN-OPERATOR
1836 C *
1837 BEGIN * GENPGEXIT *
1838 genstand prstatic 8 * HEADER LENGTH * iepp2 tn ;
1839 genstand pr0 extreturnplace itra tn ;
1840 END * GENPGEXIT * ;
1841
1842
1843 $OPTIONS page $
1844
1845 * ************************************* GENPRCEXIT *************************** *
1846
1847 PROCEDURE genprcexit fptproc : ctp ;
1848
1849 * C THIS PROCEDURE CALL THE RIGHT RETURN-OPERATOR WHOSE FUNCTIONS ARE
1850 . EXT-RETURN
1851 *RESET PR7 = STACK-HEADER
1852 *CHANGE PR6 = AND PR7|STACK-END-PTR
1853 *RESET = OPERATOR SEGMENT
1854 *RESET INDICATORS
1855 *RETURN IN CALLER
1856 . INT-RETURN
1857 *CHANGE PR6 AND PR7|STACK-END-PTR
1858 *RETURN IN CALLER
1859 C *
1860 * E ERRORS DETECTED
1861 436 ILLEGAL PROCKIND
1862 E *
1863 VAR
1864 opplace : integer ;
1865 BEGIN * GENPRCEXIT *
1866 IF fptproc # NIL THEN
1867 WITH fptproc@ DO
1868 BEGIN * POINTS A "PROC" BOX *
1869 IF prockind = actual THEN
1870 * LOCAL PASCAL PROCEDURE ===> SHORT RETURN *
1871 opplace := intreturnplace ELSE
1872 $OPTIONS compile = security $
1873 IF prockind # exportable THEN
1874 BEGIN opplace := 0 ; error 436 ;
1875 END ELSE
1876 $OPTIONS compile = true $
1877 opplace := extreturnplace ;
1878 genstand pr0 opplace itra tn ;
1879 END * WITH FPTPROCFPTPROC #NIL * ;
1880 END * GENPRCEXIT * ;
1881
1882
1883 $OPTIONS page $
1884
1885 * ************************************ GENPRCENTRY *************************** *
1886
1887 PROCEDURE genprcentry VAR unres : integer ; fptproc : ctp ; VAR fic : integer ;
1888
1889 * C .THIS PROC GENERATES CALLING SEQUENCE OF ENTRY-OPERATOR FOR THE
1890 PROCEDURE DESCRIBED BY "FPTPROC".
1891 .FIC IS THE ADDRESS OF STANDARD ENTRY SEQUENCE TO BE GENERATE
1892 .UNRES IS THE PLACE IN FICHINTER OF UNENDED INSTRUCTION USED TO KNOW
1893 THE FINAL FRAME SIZE.
1894 THIS INSTR IS RESOLVED IN LEAVEBODY WITH THE CALL OF GENINSERTION.
1895 . AN EXTERNAL PL/I PROCEDURE IS CALLED IN ORDER TO
1896 . GENERATE STANDARD ENTRY SEQUENCE
1897 . GENERATE ITS IN LINKAGE SECTION
1898 . GENERATE ALL OTHER ASSOCIATED STRUCTURES.
1899 C *
1900 VAR
1901 locsegname locentryname : alfaid ;
1902 it lcode longlist execflags locreturncode entrylength : integer ;
1903 functionflag : boolean ;
1904 BEGIN * GENPRCENTRY *
1905 $OPTIONS compile = trace $
1906 IF genetrace > none THEN
1907 BEGIN
1908 write mpcogout '@@@ DEBUT GENPRCENTRY @@@ WITH FIC:' fic ; nextline ;
1909 END ;
1910 $OPTIONS compile = true $
1911 IF fptproc # NIL THEN
1912 WITH fptproc@ DO
1913 BEGIN
1914
1915 * CALL EXTERNAL PROCEDURE FOR ITS ENTRY SEQUENCE ... *
1916 * 1RST. PARAM = BYTES OFFSET IN TEXT SECTION *
1917 * 2D. PARAM = BYTES OFFSET WANTED IN PR4 *
1918 * 3D. PARAM = CODE FOR PROCEDURE *0 INTERNAL *
1919 * *1 EXPORTABLE *
1920 * *3 MAIN *2 IMPORTED *
1921 * 4D. SEGNAME BLANK when exported
1922 5D ENTRYNAME Procedure name
1923 6D Response 0 means OK *
1924 locsegname := blank ;
1925 locentryname := name ;
1926 IF prockind = actual THEN lcode := 0 ELSE
1927 lcode := 1 ;
1928 entrylength := 0 ;
1929 functionflag := proctype <> fptproc ;
1930 IF errtotal = 0 THEN
1931 BEGIN
1932 genentrypoint fic
1933 procaddr
1934 lcode * Type of entry *
1935 locsegname
1936 locentryname
1937 functionflag
1938 entrylength
1939 locreturncode ;
1940 IF locreturncode <> 0 THEN
1941 error 503 ;
1942 END ;
1943 * NOW SELECT THE RIGHT *
1944 * OPERATOR SHORT FOR ACTUAL *
1945 IF lcode = 0 * ACTUAL * THEN
1946 BEGIN
1947 locincode := ic ;
1948 genstand nreg 0 iepp5 tic ; * PR5 = FIRST INSTR OF THIS PROC *
1949 * <=== *
1950 unres := indfich ; genstand nreg 0 ieax7 tn ; * FRAME SIZE *
1951 genstand pr0 intentryplace itsp3 tn ;
1952 genentrystructure ;
1953 END * ACTUAL * ELSE
1954 BEGIN * EXPORTABLE *
1955 IF codelist THEN
1956 FOR it := ic TO ic + entrylength - 1 DO
1957 IF it MOD bytesinword = 0 THEN
1958 BEGIN
1959 usednamesaddr@ it DIV bytesinword := octalformataddr ;
1960 usednameaddr := NIL ;
1961 END ;
1962 ic := ic + entrylength ;
1963 locincode := ic ;
1964 fic := fic + entrylength ;
1965 genstand nreg 0 iepp5 tic ; * OFFSET OF FIRST INSTR. *
1966 * LOAD PR2 WITH PASCAL OPERATOR SEGMENT *
1967 genstand pr7 transoptvptr iepp2 tny ;
1968 genstand pr2 pascoperatorsdep iepp2 tny ;
1969 IF fastoperator THEN
1970 execflags := fastbit
1971 ELSE
1972 execflags := 0 ;
1973 IF asscheck THEN execflags := execflags + checkbit ;
1974 IF interactive THEN execflags := execflags + interactivebit ;
1975 IF envstandard = stdsol THEN execflags := execflags + solstandardbit ;
1976 IF iowarnings THEN execflags := execflags + iowarningsbit ;
1977 genstand nreg execflags ildq tdl ;
1978 unres := indfich ; genstand nreg 0 ieax7 tn ; * FRAME SIZE *
1979 * NOW CALL OPERATOR *
1980 genstand pr2 extentryplace itsp3 tn ;
1981 genentrystructure ;
1982 IF mapswitch THEN BEGIN
1983 IF longprofile THEN longprofileentrysequence ;
1984 END ;
1985 END * EXPORTABLE * ;
1986 IF formals # NIL OR proctype # fptproc THEN
1987 BEGIN
1988 * MOVE ARGUMENT LIST IN CURRENT *
1989 * FRAME TO OPTIMIZE ACCESS *
1990 longlist := nbparproc * bytesindword ; * EACH ITEM IS AN ITS *
1991 IF phasdescriptor THEN
1992 longlist := longlist * 2 ;
1993 genstand pr6 argptw iepp3 tny ; * SAVING PLACE OF ARG POINTER *
1994 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1995 geneism imlr 0 p0t0r0 ;
1996 gendesca pr3 2 0 l9 longlist tn ;
1997 gendesca pr6 pascdebstacklocal DIV bytesinword 0 l9 longlist tn ;
1998 END ;
1999 END * WITH FPTPROC * ELSE
2000 BEGIN unres := 0 ; fic := 0 ;
2001 END ;
2002 IF mapswitch THEN
2003 BEGIN
2004 statement_ends currentnode^.hdrlen ;
2005 statement_begins true ;
2006 END ;
2007 $OPTIONS compile = trace $
2008 IF genetrace > low THEN
2009 BEGIN
2010 write mpcogout '@@@ FIN GENPRCENTRY @@@' ; nextline ;
2011 END ;
2012 $OPTIONS compile = true $
2013 END * GENPRCENTRY * ;
2014
2015
2016 $OPTIONS page $
2017
2018 * ************************************* CLOSEFILE **************************** *
2019
2020 PROCEDURE closefile filept : ctp ;
2021
2022 * C CALLED IN ORDER TO GENERATE CODE TO CLOSE FILE
2023 OR TO CALL THE APPROPRIATE RUN-TIME
2024 IF FILEPT IS NIL THEN DECLARATION ERROR ==> NO-OP
2025 FILEPT POINTS THE VARS BOX C *
2026 VAR
2027 lbase : preg ;
2028 BEGIN
2029 $OPTIONS compile = trace $
2030 IF genetrace > none THEN
2031 BEGIN
2032 write mpcogout '@@@ DEBUT-FIN CLOSEFILE @@@ WITH FILEPT AT @' ord filept ;
2033 nextline ;
2034 END ;
2035 $OPTIONS compile = true $
2036 IF filept # NIL THEN
2037 BEGIN
2038 * CALL OPERATOR CLOSE-FILE *
2039 * LOAD PR3 WITH F S B ADDRESS *
2040 * AND STORE IT IN FRAME *
2041 IF level = 0 THEN
2042 lbase := prstatic ELSE lbase := pr6 ;
2043 IF filept^.vkind <> actual THEN
2044 lbase := prlink ;
2045 usednameaddr := filept ;
2046 genstand lbase filept@.vaddr DIV bytesinword iepp3 tny ;
2047 genstand pr6 fsbadrw ispri3 tn ;
2048 genstand pr0 closeplace itsp3 tn ;
2049 END ;
2050 END * CLOSEFILE * ;
2051
2052
2053 $OPTIONS page $
2054
2055 * *********************************** INITIOZONE ************************* *
2056
2057 PROCEDURE initiozone filept : ctp ;
2058
2059 * C
2060 This procedure prepares the code to call INIT_FSB_ALLOC
2061 Standard files input output et error are excluded from the logic
2062 of this procedure.
2063 Parameter list description:
2064 ------------------------------
2065 ADDRESS OF POINTER on address
2066 File identification code
2067 1 Permanent 3 Workfile 5 Localfile <-- Record
2068 2 '' 4 '' 6 '' <-- Text
2069 Record_Size
2070 Number of files
2071 Pointer on name or array of names
2072
2073 C *
2074
2075 VAR
2076 filecode : integer ;
2077 lp : ctp ;
2078 it : integer ;
2079 lbase : register ;
2080 locsize : integer ;
2081 charcount : integer ;
2082
2083 BEGIN * INITIOZONE *
2084 $OPTIONS compile = trace $
2085 IF genetrace > none THEN
2086 BEGIN
2087 write mpcogout ' @@@ Debut de INITIOZONE @@@ pour FILEPT'
2088 ord filept ; nextline ;
2089 END ;
2090 $OPTIONS compile = true $
2091 WITH filept^ DO
2092 BEGIN
2093 filecode := -1 ; * Means at end required standard file *
2094 IF vfilelocation = permanentfile THEN filecode := 1 ELSE
2095 IF vfilelocation = workfile THEN filecode := 3 ELSE
2096 IF vfilelocation = localfile THEN filecode := 5 ;
2097 IF filecode >= 0 * Not required * THEN
2098 IF vtype = textfilectp THEN
2099 filecode := filecode + 1 ;
2100
2101 * At this stage FILECODE ready for call of INITFSB *
2102 IF filecode >= 0 THEN
2103 BEGIN
2104 IF level = 0 THEN lbase := prstatic ELSE
2105 lbase := pr6 ;
2106 IF vkind <> actual THEN
2107 lbase := prlink ;
2108 * Compute address of pointer on fsb and store it *
2109 usednameaddr := filept ;
2110 genstand lbase vaddr DIV bytesinword iepp2 tn ;
2111 genstand pr6 fsbadrw ispri2 tn ;
2112
2113 * Load RA with FILECODE *
2114 genstand nreg filecode ilda tdl ;
2115
2116 IF NOT odd filecode THEN
2117 locsize := iotextbuffersize * File text * ELSE
2118 locsize := vtype^.feltype^.size * File sequential * ;
2119 gencstecode locsize ildq ;
2120
2121 * Now load X1 with the numbers of files associated with
2122 this FSB pointer *
2123 genstand nreg 1 ieax1 tn ;
2124
2125 * Now load PR2 with a pointer on the names *
2126 create_konst_box lp blank alfaconst ;
2127 WITH lp^ DO
2128 BEGIN
2129 contype := alfaptr ; succ := nextalf ;
2130 END ;
2131 FOR it := 1 TO maxval DO bufval it := ' ' ;
2132 charcount := 1 ;
2133 WHILE name charcount <> ' ' AND charcount <= lgfilename DO
2134 charcount := charcount + 1 ;
2135 longstring := charcount ;
2136 bufval 1 := chr charcount - 1 ;
2137 FOR it := 2 TO charcount DO
2138 bufval it := name it - 1 ;
2139 nextalf := lp ; crealfabox lp ;
2140 enterundlab lp^.unddeb ;
2141 genstand nreg 0 iepp2 tic ;
2142
2143 genstand pr0 initfsballocplace itsp3 tn ;
2144
2145 END * FILECODE >= 0 else NOCALL * ;
2146 END * With FILEPT * ;
2147
2148 $OPTIONS compile = trace $
2149 IF genetrace > low THEN
2150 BEGIN
2151 write mpcogout ' @@@ Fin de INITIOZONE @@@ ' ; nextline ;
2152 END ;
2153 $OPTIONS compile = true $
2154 END * INITIOZONE * ;
2155
2156
2157 $OPTIONS page $
2158
2159 * ******************************** GEN_INIT_FSB_TRAP_STRUCTURES ********************* *
2160
2161 PROCEDURE gen_init_fsb_trap_structures filpt : ctp ;
2162
2163 VAR
2164 it : integer ;
2165 locreturncode : integer ;
2166 entrylength : integer ;
2167 lp : ctp ;
2168 charcount : integer ;
2169 BEGIN
2170 WITH filpt^ DO
2171 IF vfilelocation IN permanentfile workfile AND NOT vkind = imported THEN
2172 BEGIN
2173 IF init_fsb_trap_flag THEN
2174 BEGIN
2175 init_fsb_trap_flag := false ;
2176 init_fsb_trap_number_of_files := 1 ;
2177 init_fsb_trap_info_place := ic ;
2178 lkc := recadre lkc bytesindword ;
2179 init_fsb_trap_links_place := lkc ;
2180 lkc := lkc + 2 * bytesindword ;
2181 genentrypoint 0 init_fsb_trap_links_place 2 'pascal_io_'
2182 'pascal_init_fsb_trap_proc_' false entrylength locreturncode ;
2183 IF locreturncode <> 0 THEN error 505 ;
2184 genentrypoint ic init_fsb_trap_links_place + bytesindword
2185 4 blank blank false entrylength locreturncode ;
2186 IF locreturncode <> 0 THEN error 505 ;
2187 usednameaddr := octalformataddr ;
2188 infich 2 ; * VERSION NUMBER FOR TRAP_INFO STRUCTURE *
2189 infich 0 ; * NUMBER OF FILES. FILLED LATER IN PASCAL_BUILD_OBJECT *
2190 genreltext absl 2 ;
2191 END ELSE
2192 init_fsb_trap_number_of_files := init_fsb_trap_number_of_files + 1 ;
2193 usednameaddr := octalformataddr ;
2194 infich vaddr DIV bytesinword ;
2195 IF vkind = exportable THEN genreltext link15 1
2196 ELSE genreltext int15 1 ;
2197 infich '350100'o * FOR epp0 0|vaddr INSTRUCTION RELOCATED BY BINDER * ;
2198 genreltext absl 1 ;
2199 create_konst_box lp blank alfaconst ;
2200 WITH lp^ DO
2201 BEGIN
2202 contype := alfaptr ; succ := nextalf ;
2203 END ;
2204 FOR it := 1 TO maxval DO bufval it := ' ' ;
2205 charcount := 1 ;
2206 WHILE name charcount <> ' ' AND charcount <= lgfilename DO
2207 charcount := charcount + 1 ;
2208 longstring := charcount ;
2209 bufval 1 := chr charcount - 1 ;
2210 FOR it := 2 TO charcount DO
2211 bufval it := name it - 1 ;
2212 nextalf := lp ; crealfabox lp ;
2213 enterundlab lp^.unddeb ;
2214 usednameaddr := octalformataddr ;
2215 infich 0 ; genreltext self_rel 1 ;
2216 infich 1 + 2 * ord vfilelocation = workfile + ord vtype = textfilectp * twoto14 + 1 ;
2217 genreltext absl 1 ;
2218 usednameaddr := octalformataddr ;
2219 IF vtype = textfilectp THEN
2220 genc iotextbuffersize * File text * ELSE
2221 genc vtype^.feltype^.size * File sequential * ;
2222 genreltext absl 2 ;
2223 END ;
2224 END * INIT_FSB_TRAP_STRUCTURES * ;
2225
2226 $OPTIONS page$
2227
2228 * ***********************************************WRITOUT********************** *
2229
2230 PROCEDURE writout zonedisp endcode : integer ;
2231
2232 * C . MUST BE CALLED ONLY IF ENVIRONT = DATA ACTUAL GLOBAL INIT.
2233 ENVIRONT = TEXT ALM CODE FOR A BODY
2234 . ZONEDISP IS THE BYTE ADDRESS OF THE FIRST ITEM TO BE GENERATE
2235 C *
2236 * E ERRORS DETECTED
2237 504 Auto-controle de GENBINAREA
2238 E *
2239
2240 VAR
2241 areacode : integer ;
2242 locreturncode : integer ;
2243 BEGIN * WRITOUT *
2244 $OPTIONS compile = trace $
2245 IF genetrace > none THEN
2246 BEGIN
2247 write mpcogout '@@@ DEBUT WRITOUT @@@ WITH ZONEDISPINDFICHENVIRONT :'
2248 zonedisp indfich ord environt ;
2249 nextline ;
2250 END ;
2251 $OPTIONS compile = true $
2252 IF errtotal = 0 THEN BEGIN
2253 IF environt = data THEN areacode := 3
2254 ELSE BEGIN
2255 areacode := 1 ;
2256 genreltext absl indfich - 1 - endcode ;
2257 END ;
2258 genbinarea zonedisp areacode indfich - 1 endcode fichinter^ locreturncode ;
2259 IF locreturncode <> 0 THEN
2260 BEGIN
2261 error 504 ;
2262 * Sequence filled later if necessary *
2263 END ;
2264 END ;
2265 indfich := 1 ;
2266 $OPTIONS compile = trace $
2267 IF genetrace > low THEN
2268 BEGIN
2269 write mpcogout '@@@ FIN WRITOUT @@@' ; nextline ;
2270 END ;
2271 $OPTIONS compile = true $
2272 END * WRITOUT * ;
2273
2274 * END OF THE MODULE GENERE *************** * BEGIN
2275 END.