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 PROGRAM modattr ;
19
20 $OPTIONS switch trace := true ; switch security := true ; t + $
21
22
23 $IMPORT
24 * IMPORTED PROCEDURES *
25 'RACINE pascal ' :
26 error,
27 nextline ;
28 'STATE pascal ' :
29 freebloc,
30 newbloc,
31 printstatusregister,
32 sauvereg ;
33 'STATE pascal ' :
34 transfer ;
35 'GENERE pascal ' :
36 genstand ;
37
38 * IMPORTED VARIABLES *
39 'GENERE pascal' :
40 illegal_generation ;
41 'RACINE pascal ' :
42 boxheader,
43 charptr,
44 envstandard,
45 declarationpart,
46 level,
47 mpcogout,
48 nilptr,
49 realptr,
50 string_ptr ;
51 'STATE pascal ' :
52 currentbloc,
53 maxprused,
54 regname,
55 stattrace,
56 tabacc,
57 tabkind
58 $
59
60 $EXPORT
61 convreal,
62 easyvar,
63 is_pl1_varying_char,
64 freeattr,
65 initattrvarbl,
66 is_possible_string,
67 isstring,
68 lvalvarbl,
69 printattr,
70 varissimple
71 $
72
73 $INCLUDE 'CONSTTYPE' $
74
75 $OPTIONS page $
76
77 VAR
78 * REDEFINE IMPORTED VARIABLES *
79 * FROM RACINE *
80
81 boxheader : PACKED ARRAY 1..120 OF char ;
82 charptr : ctp ;
83 declarationpart : boolean ;
84 envstandard : stdkind ;
85 level : levrange ;
86 mpcogout : text ;
87 nilptr : ctp ;
88 realptr : ctp ;
89 string_ptr : ctp ;
90
91 * FROM GENERE *
92 illegal_generation : boolean ;
93
94
95 * FROM STATE *
96
97 currentbloc : regpt ; * LAST CREATED BOX REGISTER *
98 maxprused : preg ; * LAST POINTER REGISTER USED IN GETPR *
99 regname : ARRAY register OF PACKED ARRAY 1..4 OF char ; * REGIST. NAMES *
100 stattrace : levtrace ; * TRACE FOR MODULE STATEMENT *
101 tabacc : ARRAY attraccess OF alfa ; * MNEMONICS USED IN TRACE *
102 tabkind : ARRAY attrkind OF alfa ; * MNEMONICS USED IN TRACE *
103 $OPTIONS page $
104
105 * REDEFINE IMPORTED PROCEDURES *
106 * FROM RACINE *
107
108 PROCEDURE error errno : integer ; EXTERNAL ;
109 PROCEDURE nextline ; EXTERNAL ;
110
111 * FROM STATE *
112
113 PROCEDURE freebloc VAR fbtofree : regpt ; EXTERNAL ;
114 PROCEDURE newbloc freg : register ; EXTERNAL ;
115 PROCEDURE printstatusregister ; EXTERNAL ;
116 PROCEDURE sauvereg freg : register ; fload : boolean ; EXTERNAL ;
117
118 * FROM STATE *
119
120 PROCEDURE transfer VAR fattr : attr ; inwhat : destination ; EXTERNAL ;
121
122 * FROM GENERE *
123
124 PROCEDURE genstand fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag ; EXTERNAL ;
125
126 $OPTIONS page $
127
128 * ************************************ PRINTATTR ***************************** *
129
130 PROCEDURE printattr VAR fattr : attr ;
131
132 * C USED IN TRACE CONTEXT IN ORDER TO PRINT
133 . LOADED REGISTERS
134 . MEANINGSFULL FIELDS OF FATTR
135 C *
136 VAR
137 it : integer ;
138 BEGIN * PRINTATTR *
139 write mpcogout boxheader ; nextline ;
140 printstatusregister ;
141 WITH fattr DO
142 BEGIN
143 IF typtr = NIL THEN
144 write mpcogout '* REQUESTED ATTR HAS A TYPTR AT NIL' ELSE
145 BEGIN
146 write mpcogout '* TYPTR IS AT @' ord typtr
147 ' FATTR_KIND IS:' tabkind kind ;
148 nextline ;
149 CASE kind OF
150 varbl : BEGIN
151 write mpcogout '* VLEVBASEREG ARE:' vlev : 4 regname basereg : 9
152 ' BASEBLOC IS AT @' ord basebloc ' DPLMTPCKD ARE:' dplmt
153 pckd : 6 ;
154 nextline ;
155 write mpcogout '* INXREGINXMEMINXMEMRW ARE:' regname inxreg : 9
156 inxmem inxmemrw : 6 ' INXBLOC IS AT @' ord inxbloc ;
157 nextline ;
158 write mpcogout '* ACCESS IS:' tabacc access
159 ' ITSDPLMT IS:' itsdplmt ;
160 write mpcogout ' DESCREG IS ' regname descreg ' DESCBLOC AT @' ord descbloc ;
161 END * VARBL * ;
162 lval : BEGIN
163 write mpcogout '* LDREG IS ' regname ldreg ' LDREGBLOC IS AT @'
164 ord ldregbloc ;
165 IF ldreg = psr THEN write mpcogout ' PSRSIZE IS:' psrsize ;
166 END * LVAL * ;
167 chain : write mpcogout '* ALFACTP IS AT @' ord alfactp ;
168 sval : BEGIN
169 IF typtr = realptr THEN
170 write mpcogout '* RSVAL IS' rsval ELSE
171 IF typtr = nilptr THEN
172 write mpcogout '* SVAL IS "NIL" ' ELSE
173 IF typtr@.form = power THEN
174 BEGIN
175 write mpcogout '* SETS. LONGV IS' longv ' VALPW0..7 ARE' ;
176 FOR it := 0 TO 7 DO
177 write mpcogout '*' valpw it ;
178 END * SETS * ELSE
179 write mpcogout '* VAL IS :' val ;
180 END * SVAL * ;
181 lcond : BEGIN
182 write mpcogout '* ACCBOOL IS:' accbool : 6
183 ' ACCBLOC IS AT @' ord accbloc
184 ' TRANSF IS:' transf : 4 ;
185 END * LCOND * ;
186 END * CASE KIND * ;
187 END * TYPTR # NIL * ;
188 END * WITH FATTR * ;
189 nextline ;
190 write mpcogout boxheader ; nextline ;
191 END * PRINTATTR * ;
192
193 $OPTIONS page $
194
195 * ******************************************** INITATTRVARBL ******************************** *
196
197 PROCEDURE initattrvarbl VAR fattr : attr ;
198
199 BEGIN
200 WITH fattr DO
201 BEGIN
202 kind := varbl ;
203 vlev := level ;
204 basereg := pr6 ;
205 basebloc := NIL ;
206 access := direct ;
207 dplmt := 0 ;
208 inxreg := nxreg ;
209 inxbloc := NIL ;
210 inxmem := 0 ;
211 inxmemrw := true ;
212 itsdplmt := 0 ;
213 pckd := false ;
214 nameaddr := NIL ;
215 descreg := nreg ;
216 descbloc := NIL ;
217 temporary := false ;
218 END ;
219 END * INITATTRVARBL * ;
220
221 $OPTIONS page $
222
223 * ******************************* IS_PL1_VARYING_CHAR *********************** *
224
225 FUNCTION is_pl1_varying_char VAR typectp : ctp : boolean ;
226
227 VAR
228 locbool : boolean ;
229 locctp_1, locctp_2 : ctp ;
230 locmax : integer ;
231
232 BEGIN
233 locbool := false ;
234 IF typectp <> NIL THEN
235 WITH typectp^ DO
236 IF form = records THEN
237 IF recvar = NIL AND fstfld <> NIL THEN
238 IF fstfld^.fldtype <> NIL AND fstfld^.nxtel <> NIL THEN
239 BEGIN
240 locctp_1 := fstfld ;
241 WITH locctp_1^.fldtype^ DO
242 BEGIN
243 IF form = numeric THEN
244 IF nmin = 0 THEN
245 BEGIN
246 locmax := nmax ;
247 locctp_2 := locctp_1^.nxtel ;
248 IF locctp_2 <> NIL AND locctp_2^.nxtel = NIL THEN
249 IF locctp_2^.fldtype <> NIL THEN
250 WITH locctp_2^.fldtype^ DO
251 IF form = arrays THEN
252 IF pack THEN
253 IF aeltype = charptr THEN
254 IF inxtype <> NIL THEN
255 IF inxtype^.form = numeric THEN
256 IF lo = 1 AND hi = locmax THEN
257 locbool := true ;
258 END ;
259 END ;
260 END ;
261 is_pl1_varying_char := locbool ;
262 END * IS_PL1_VARYING_CHAR * ;
263 $OPTIONS page $
264
265 * ************************************ FCT. ISSTRING ************************* *
266
267 FUNCTION isstring VAR fattr : attr : boolean ;
268
269 * C RETURNS TRUE IF FATTR DESCRIBES A "STRING"
270 . PACKED ARRAY OF CHAR
271 . CHAIN * FATTR IS NOT ALTERED
272 C *
273 BEGIN * ISSTRING *
274 $OPTIONS compile = trace $
275 IF stattrace > none THEN
276 BEGIN
277 write mpcogout '@@@ DEBUT-FIN ISSTRING @@@' ; nextline ;
278 END ;
279 $OPTIONS compile = true $
280 isstring := false ;
281 WITH fattr DO
282 IF typtr # NIL THEN
283 IF kind = chain THEN
284 * <--- * isstring := true ELSE
285 WITH typtr@ DO
286 IF form = arrays THEN
287 IF pack THEN
288 IF aeltype = charptr THEN
289 IF inxtype # NIL THEN
290 IF inxtype@.form = numeric THEN
291 IF envstandard <> stdextend THEN
292 BEGIN
293 IF NOT conformant THEN
294 IF lo = 1 THEN isstring := true ;
295 END ELSE
296 isstring := true ;
297 END * ISSTRING * ;
298
299
300 $OPTIONS page $
301
302 * ************************************ FCT. VARISSIMPLE ********************* *
303 FUNCTION varissimple VAR fattr : attr : boolean ;
304
305 * C RETURNS TRUE WHEN FATTR DESCRIBES A VARIABLE EASY TO ADDRESS
306 NO CHANGE FOR FATTR
307 C *
308 VAR
309 variss : boolean ;
310 BEGIN * VARISSIMPLE *
311 variss := false ;
312 WITH fattr DO
313 IF access = direct THEN
314 IF vlev = 0 OR vlev = level THEN
315 IF inxreg = nxreg THEN
316 IF inxmem = 0 THEN
317 * <--- *
318 variss := true ;
319 varissimple := variss ; * <--------- *
320 $OPTIONS compile = trace $
321 IF stattrace > low THEN
322 BEGIN
323 write mpcogout ' @@@ Fin de VARISSIMPLE @@@ avec valeur retournee:'
324 variss ;
325 nextline ;
326 END ;
327 $OPTIONS compile = true $
328 END * VARISSIMPLE * ;
329
330
331 $OPTIONS page $
332
333 * ************************************ FCT. EASYVAR ************************** *
334
335 FUNCTION easyvar VAR fattr : attr : boolean ;
336
337 * C ."FATTR" IS NOT CHANGED
338 .RETURNS TRUE FOR AN EASY ADDRESSED VARIABLE
339 * NOT PACKED INDEX NOT SAVED NO STORAGE INDEX
340 C *
341 * E ERRORS DETECTED
342 430 TYPTR = NIL
343 431 KIND # VARBL
344 E *
345 VAR
346 easyv : boolean ;
347 BEGIN * EASYVAR *
348 easyv := false ;
349 $OPTIONS compile = trace $
350 IF stattrace > none THEN
351 BEGIN
352 write mpcogout '@@@ DEBUT EASYVAR @@@' ; nextline ;
353 END ;
354 $OPTIONS compile = true $
355 $OPTIONS compile = security $
356 IF fattr.typtr = NIL THEN error 430 ELSE
357 IF fattr.kind # varbl THEN error 431 ELSE
358 $OPTIONS compile = true $
359 WITH fattr DO
360 IF NOT pckd THEN
361 IF inxmem = 0 THEN
362 IF inxbloc = NIL THEN
363 easyv := true ELSE
364 IF inxbloc@.saveplace = 0 THEN
365 easyv := true ;
366 easyvar := easyv ;
367 $OPTIONS compile = trace $
368 IF stattrace > low THEN
369 BEGIN
370 write mpcogout '@@@ FIN EASYVAR @@@ WITH RETURNED VALUE:' easyv ; nextline ;
371 END ;
372 $OPTIONS compile = true $
373 END * EASYVAR * ;
374
375 $OPTIONS page $
376
377 * ************************************ FREEATTR ****************************** *
378
379 PROCEDURE freeattr VAR fattr : attr ;
380
381 * C THIS PROCEDURE DOESN'T MODIFY FATTR BUT FREES ALL ASSOCIATED BOXES
382 AND REGISTERS
383 C *
384 BEGIN * FREEATTR *
385 $OPTIONS compile = trace $
386 IF stattrace > none THEN
387 BEGIN
388 write mpcogout '@@@ DEBUT FREEATTR @@@' ; nextline ;
389 END ;
390 $OPTIONS compile = true $
391 WITH fattr DO
392 CASE kind OF
393 lval : freebloc ldregbloc ;
394 varbl :
395 BEGIN IF basereg <= maxprused THEN freebloc basebloc ;
396 IF inxreg # nxreg THEN freebloc inxbloc ;
397 freebloc descbloc ;
398 END * VARBL * ;
399 lcond : IF accbool THEN freebloc accbloc ;
400 sval, chain : ;
401 END * CASE KINDWITH FATTR * ;
402 $OPTIONS compile = trace $
403 IF stattrace > low THEN
404 BEGIN
405 write mpcogout '@@@ FIN FREEATTR @@@' ; nextline ;
406 END ;
407 $OPTIONS compile = true $
408 END * FREEATTR * ;
409
410 $OPTIONS page $
411
412 * ************************************ LVALVARBL ***************************** *
413
414 PROCEDURE lvalvarbl VAR fattr : attr ;
415
416 * C .MUST BE CALLED ONLY FOR "LVAL"
417 .CHANGES THIS ATTR INTO A VARIABLE DIRECT FROM CURRENT LEVEL.
418 EITHER FOR A SAVED REGISTER
419 EITHER FOR PSR
420 .IN OTHER CASES NO OPERATION
421 C *
422 * E ERRORS DETECTED
423 425 FATTR.KIND MUST BE LVAL
424 426 FATTR.LDREGBLOC IS NIL
425 E *
426 VAR
427 locdep : integer ;
428 BEGIN * LVALVARBL *
429 $OPTIONS compile = trace $
430 IF stattrace > none THEN
431 BEGIN write mpcogout '@@@ DEBUT LVALVARBL @@@' ; nextline ;
432 END ;
433 $OPTIONS compile = true $
434 $OPTIONS compile = security $
435 IF fattr.kind # lval THEN error 425 ELSE
436 IF fattr.ldregbloc = NIL THEN error 426 ELSE
437 $OPTIONS compile = true $
438 WITH fattr DO
439 BEGIN
440 IF ldregbloc@.saveplace # 0 THEN * SAVED REGISTER *
441 locdep := ldregbloc@.saveplace ELSE
442 IF ldreg = psr THEN
443 locdep := psrdepb ELSE
444 locdep := 0 ;
445 IF locdep # 0 THEN
446 BEGIN
447 freebloc ldregbloc ;
448 * NOW CHANGE FATTR *
449 initattrvarbl fattr ;
450 dplmt := locdep ;
451 $OPTIONS compile = trace $
452 IF stattrace > none THEN
453 BEGIN write mpcogout '* LVALVARBL .ATTR RECEIVED BECOMES DIRECT' ;
454 nextline ;
455 END ;
456 $OPTIONS compile = true $
457 END ;
458 END * WITH FATTR * ;
459 $OPTIONS compile = trace $
460 IF stattrace > low THEN
461 BEGIN
462 write mpcogout '@@@ FIN LVALVARBL @@@' ; nextline ;
463 END ;
464 $OPTIONS compile = true $
465 END * LVALVARBL * ;
466
467 $OPTIONS page $
468
469 * ************************************ CONVREAL ****************************** *
470
471 PROCEDURE convreal VAR fattr : attr ;
472
473 * C WORKS ON A NUMERIC ATTR
474 .SVAL CHANGE IT IN RSVAL
475 .NOT LVAL TRANSFER AND CALL OPERATOR
476 .LVAL SAVED TRANSFER. OPERATOR.
477 C *
478 * E ERRORS DETECTED
479 402: TYPTR@.FORM MUST BE NUMERIC
480 411: TYPTR IS NIL
481 E *
482 VAR
483 lop : integer ;
484 BEGIN * CONVREAL *
485 $OPTIONS compile = trace $
486 IF stattrace > none THEN
487 BEGIN
488 write mpcogout '@@@ DEBUT CONVREAL @@@' ; nextline ;
489 END ;
490 $OPTIONS compile = true $
491 $OPTIONS compile = security $
492 IF fattr.typtr = NIL THEN error 411 ELSE
493 IF fattr.typtr@.form # numeric THEN error 402 ELSE
494 $OPTIONS compile = true $
495 WITH fattr DO
496 BEGIN
497 IF kind = sval THEN
498 rsval := val ELSE
499 IF declarationpart THEN illegal_generation := true
500 ELSE
501 BEGIN
502 IF kind = lval THEN
503 lvalvarbl fattr ;
504 IF kind # lval THEN
505 transfer fattr inacc ;
506 IF ldreg = ra THEN
507 BEGIN
508 sauvereg rq false ; lop := rafltplace ;
509 END ELSE
510 BEGIN
511 sauvereg ra false ; lop := rqfltplace ;
512 END ;
513 genstand pr0 lop itsp3 tn ;
514 freebloc ldregbloc ; newbloc reaq ;
515 ldreg := reaq ; ldregbloc := currentbloc ;
516 END ;
517 typtr := realptr ;
518 END * WITH FATTR * ;
519 $OPTIONS compile = trace $
520 IF stattrace > low THEN
521 BEGIN
522 write mpcogout '@@@ FIN CONVREAL @@@' ; nextline ;
523 END ;
524 $OPTIONS compile = true $
525 END * CONVREAL * ;
526
527 $OPTIONS page $
528
529 * ***************************** IS_POSSIBLE_STRING *********************** *
530
531 FUNCTION is_possible_string VAR fattr : attr : boolean ;
532
533 BEGIN
534 IF fattr.typtr = NIL THEN is_possible_string := false ELSE
535 is_possible_string := isstring fattr OR fattr.typtr^.father_schema = string_ptr OR fattr.typtr = charptr ;
536 END ;
537
538 BEGIN
539 END.