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) change(86-09-11,JMAthane), approve(86-09-11,MCR7521),
 13      audit(86-09-15,JPFauche), install(86-11-12,MR12.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, '* VLEV,BASEREG ARE:', vlev : 4, regname [basereg] : 9,
152                         ' BASEBLOC IS AT @', ord (basebloc), ' DPLMT,PCKD ARE:', dplmt,
153                         pckd : 6) ;
154                       nextline ;
155                       write (mpcogout, '* INXREG,INXMEM,INXMEMRW 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 KIND,WITH 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.