gcc/m2/gm2-compiler/M2Const.mod

   1 (* M2Const.mod maintain and resolve the types of constants.
   2
   3 Copyright (C) 2010-2024 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Modula-2; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  *)
  21
  22 IMPLEMENTATION MODULE M2Const ;
  23
  24 (*
  25 CONST
  26    Debugging   = FALSE ;
  27    DebugConsts = FALSE ;
  28
  29 TYPE
  30    constList = POINTER TO cList ;
  31    cList     = RECORD
  32                   constsym : CARDINAL ;
  33                   constmeta: constType ;
  34                   expr     : CARDINAL ;
  35                   type     : CARDINAL ;
  36                   next     : constList ;
  37                END ;
  38
  39
  40 VAR
  41    headOfConsts: constList ;
  42
  43
  44 PROCEDURE stop ; BEGIN END stop ;
  45
  46
  47 (*
  48    addToConstList - add a constant, sym, to the head of the constants list.
  49 *)
  50
  51 PROCEDURE addToConstList (sym: CARDINAL) ;
  52 VAR
  53    h: constList ;
  54 BEGIN
  55    h := headOfConsts ;
  56    WHILE h#NIL DO
  57       IF h^.constsym=sym
  58       THEN
  59          InternalError ('should never see the same symbol id declared twice')
  60       END ;
  61       h := h^.next
  62    END ;
  63    NEW(h) ;
  64    WITH h^ DO
  65       constsym  := sym ;
  66       constmeta := unknown ;
  67       expr      := NulSym ;
  68       type      := NulSym ;
  69       next      := headOfConsts
  70    END ;
  71    headOfConsts := h
  72 END addToConstList ;
  73
  74
  75 (*
  76    FixupConstAsString - fixes up a constant, sym, which will have the string type.
  77 *)
  78
  79 PROCEDURE FixupConstAsString (sym: CARDINAL) ;
  80 BEGIN
  81    fixupConstMeta(sym, str)
  82 END FixupConstAsString ;
  83
  84
  85 (*
  86    FixupConstType - fixes up a constant, sym, which will have the type, consttype.
  87 *)
  88
  89 PROCEDURE FixupConstType (sym: CARDINAL; consttype: CARDINAL) ;
  90 VAR
  91    h: constList ;
  92 BEGIN
  93    h := headOfConsts ;
  94    WHILE h#NIL DO
  95       WITH h^ DO
  96          IF constsym=sym
  97          THEN
  98             IF constmeta=str
  99             THEN
 100                InternalError ('cannot fix up a constant to have a type if it is already known as a string')
 101             END ;
 102             type := consttype ;
 103             PutConst(sym, consttype) ;
 104             RETURN
 105          END
 106       END ;
 107       h := h^.next
 108    END
 109 END FixupConstType ;
 110
 111
 112 (*
 113    FixupProcedureType - creates a proctype from a procedure.
 114 *)
 115
 116 PROCEDURE FixupProcedureType (p: CARDINAL) : CARDINAL ;
 117 VAR
 118    par,
 119    t   : CARDINAL ;
 120    n, i: CARDINAL ;
 121 BEGIN
 122    IF IsProcedure(p)
 123    THEN
 124       t := MakeProcType(CheckAnonymous(NulName)) ;
 125       i := 1 ;
 126       n := NoOfParam(p) ;
 127       WHILE i<=n DO
 128          par := GetParam(p, i) ;
 129          IF IsParameterVar(par)
 130          THEN
 131             PutProcTypeVarParam(t, GetType(par), IsParameterUnbounded(par))
 132          ELSE
 133             PutProcTypeParam(t, GetType(par), IsParameterUnbounded(par))
 134          END ;
 135          INC(i)
 136       END ;
 137       IF GetType(p)#NulSym
 138       THEN
 139          PutFunction(t, GetType(p))
 140       END ;
 141       RETURN( t )
 142    ELSE
 143       InternalError ('expecting a procedure')
 144    END ;
 145    RETURN( NulSym )
 146 END FixupProcedureType ;
 147
 148
 149 (*
 150    FixupConstProcedure - fixes up a constant, sym, which will be equivalent to e.
 151 *)
 152
 153 PROCEDURE FixupConstProcedure (sym: CARDINAL; e: CARDINAL) ;
 154 VAR
 155    h: constList ;
 156 BEGIN
 157    h := headOfConsts ;
 158    WHILE h#NIL DO
 159       WITH h^ DO
 160          IF constsym=sym
 161          THEN
 162             expr := e ;
 163             type := FixupProcedureType(e) ;
 164             PutConst(sym, type) ;
 165             RETURN
 166          END
 167       END ;
 168       h := h^.next
 169    END
 170 END FixupConstProcedure ;
 171
 172
 173 (*
 174    FixupConstExpr - fixes up a constant, sym, which will be equivalent to e.
 175 *)
 176
 177 PROCEDURE FixupConstExpr (sym: CARDINAL; e: CARDINAL) ;
 178 VAR
 179    h: constList ;
 180 BEGIN
 181    h := headOfConsts ;
 182    WHILE h#NIL DO
 183       WITH h^ DO
 184          IF constsym=sym
 185          THEN
 186             expr := e ;
 187             RETURN
 188          END
 189       END ;
 190       h := h^.next
 191    END
 192 END FixupConstExpr ;
 193
 194
 195 (*
 196    fixupConstMeta - fixes up symbol, sym, to have the, meta, constType.
 197 *)
 198
 199 PROCEDURE FixupConstMeta (sym: CARDINAL; meta: constType) ;
 200 VAR
 201    h: constList ;
 202 BEGIN
 203    h := headOfConsts ;
 204    WHILE h#NIL DO
 205       WITH h^ DO
 206          IF constsym=sym
 207          THEN
 208             constmeta := meta ;
 209             RETURN
 210          END
 211       END ;
 212       h := h^.next
 213    END
 214 END FixupConstMeta ;
 215
 216
 217 (*
 218    fixupConstCast -
 219 *)
 220
 221 PROCEDURE fixupConstCast (sym: CARDINAL; castType: CARDINAL) ;
 222 VAR
 223    h: constList ;
 224 BEGIN
 225    h := headOfConsts ;
 226    WHILE h#NIL DO
 227       WITH h^ DO
 228          IF constsym=sym
 229          THEN
 230             type := castType ;
 231             RETURN
 232          END
 233       END ;
 234       h := h^.next
 235    END
 236 END fixupConstCast ;
 237
 238
 239 (*
 240    findConstType -
 241 *)
 242
 243 PROCEDURE findConstType (sym: CARDINAL) : CARDINAL ;
 244 VAR
 245    h: constList ;
 246    t: CARDINAL ;
 247 BEGIN
 248    h := headOfConsts ;
 249    WHILE h#NIL DO
 250       WITH h^ DO
 251          IF constsym=sym
 252          THEN
 253             t := GetType(sym) ;
 254             IF t=NulSym
 255             THEN
 256                RETURN( NulSym )
 257             ELSE
 258                RETURN( t )
 259             END
 260          END
 261       END ;
 262       h := h^.next
 263    END ;
 264    RETURN( NulSym )
 265 END findConstType ;
 266
 267
 268 (*
 269    findConstMeta -
 270 *)
 271
 272 PROCEDURE findConstMeta (sym: CARDINAL) : constType ;
 273 VAR
 274    h: constList ;
 275 BEGIN
 276    h := headOfConsts ;
 277    WHILE h#NIL DO
 278       WITH h^ DO
 279          IF constsym=sym
 280          THEN
 281             RETURN( constmeta )
 282          END
 283       END ;
 284       h := h^.next
 285    END ;
 286    RETURN( unknown )
 287 END findConstMeta ;
 288
 289
 290 (*
 291    ReportUnresolvedConstTypes - emits an error message for any unresolved constant type.
 292 *)
 293
 294 PROCEDURE ReportUnresolvedConstTypes ;
 295 VAR
 296    h: constList ;
 297 BEGIN
 298    h := headOfConsts ;
 299    WHILE h#NIL DO
 300       WITH h^ DO
 301          IF (constmeta#unknown) AND (constmeta#str) AND (type=NulSym)
 302          THEN
 303             MetaError1('unable to resolve the type of the constant {%1Dad}', h^.constsym)
 304          END
 305       END ;
 306       h := h^.next
 307    END
 308 END ReportUnresolvedConstTypes ;
 309
 310
 311 (*
 312    DebugMeta -
 313 *)
 314
 315 PROCEDURE DebugMeta (h: constList) ;
 316 VAR
 317    n: Name ;
 318 BEGIN
 319    IF DebugConsts
 320    THEN
 321       WITH h^ DO
 322          n := GetSymName(constsym) ;
 323          printf1('constant %a ', n) ;
 324          IF type=NulSym
 325          THEN
 326             printf0('type is unknown\n')
 327          ELSE
 328             printf0('type is known\n')
 329          END
 330       END
 331    END
 332 END DebugMeta ;
 333
 334
 335 (*
 336    constTypeResolved -
 337 *)
 338
 339 PROCEDURE constTypeResolved (h: constList) : BOOLEAN ;
 340 BEGIN
 341    RETURN( h^.type#NulSym )
 342 END constTypeResolved ;
 343
 344
 345 (*
 346    constExprResolved -
 347 *)
 348
 349 PROCEDURE constExprResolved (h: constList) : BOOLEAN ;
 350 BEGIN
 351    RETURN( h^.expr#NulSym )
 352 END constExprResolved ;
 353
 354
 355 (*
 356    findConstMetaExpr -
 357 *)
 358
 359 PROCEDURE findConstMetaExpr (h: constList) : constType ;
 360 BEGIN
 361    RETURN( h^.constmeta )
 362 END findConstMetaExpr ;
 363
 364
 365 (*
 366    constResolveViaMeta -
 367 *)
 368
 369 PROCEDURE constResolveViaMeta (h: constList) : BOOLEAN ;
 370 VAR
 371    n: Name ;
 372 BEGIN
 373    WITH h^ DO
 374       IF findConstMetaExpr(h)=str
 375       THEN
 376          PutConstString(constsym, MakeKey('')) ;
 377          IF DebugConsts
 378          THEN
 379             n := GetSymName(constsym) ;
 380             printf1('resolved constant %a as a string\n', n)
 381          END ;
 382          RETURN( TRUE )
 383       END
 384    END ;
 385    RETURN( FALSE )
 386 END constResolveViaMeta ;
 387
 388
 389 (*
 390    constResolvedViaType -
 391 *)
 392
 393 PROCEDURE constResolvedViaType (h: constList) : BOOLEAN ;
 394 VAR
 395    n: Name ;
 396 BEGIN
 397    WITH h^ DO
 398       type := findConstType(expr) ;
 399       IF type#NulSym
 400       THEN
 401          PutConst(constsym, type) ;
 402          IF DebugConsts
 403          THEN
 404             n := GetSymName(constsym) ;
 405             printf1('resolved type of constant %a\n', n)
 406          END ;
 407          RETURN( TRUE )
 408       END
 409    END ;
 410    RETURN( FALSE )
 411 END constResolvedViaType ;
 412
 413
 414 (*
 415    resolveConstType -
 416 *)
 417
 418 PROCEDURE resolveConstType (h: constList) : BOOLEAN ;
 419 BEGIN
 420    WITH h^ DO
 421       IF (constmeta=unknown) OR (constmeta=str)
 422       THEN
 423          (* do nothing *)
 424       ELSE
 425          DebugMeta(h) ;
 426          IF constTypeResolved(h)
 427          THEN
 428             (* nothing to do *)
 429          ELSE
 430             IF constExprResolved(h)
 431             THEN
 432                IF constResolveViaMeta(h)
 433                THEN
 434                   RETURN( TRUE )
 435                ELSIF constResolvedViaType(h)
 436                THEN
 437                   RETURN( TRUE )
 438                END
 439             END
 440          END
 441       END
 442    END ;
 443    RETURN( FALSE )
 444 END resolveConstType ;
 445
 446
 447 (*
 448    ResolveConstTypes - resolves the types of all aggegrate constants.
 449 *)
 450
 451 PROCEDURE ResolveConstTypes ;
 452 VAR
 453    h      : constList ;
 454    changed: BOOLEAN ;
 455 BEGIN
 456    REPEAT
 457       changed := FALSE ;
 458       h := headOfConsts ;
 459       WHILE h#NIL DO
 460          changed := resolveConstType(h) ;
 461          h := h^.next
 462       END
 463    UNTIL NOT changed ;
 464    ReportUnresolvedConstTypes
 465 END ResolveConstTypes ;
 466
 467
 468 (*
 469    SkipConst - returns the symbol which is a pseudonum of, sym.
 470 *)
 471
 472 PROCEDURE SkipConst (sym: CARDINAL) : CARDINAL ;
 473 VAR
 474    init: CARDINAL ;
 475    h   : constList ;
 476 BEGIN
 477    init := sym ;
 478    h := headOfConsts ;
 479    WHILE h#NIL DO
 480       IF (h^.constsym=sym) AND (h^.expr#NulSym)
 481       THEN
 482          sym := h^.expr ;
 483          IF sym=init
 484          THEN
 485             (* circular definition found *)
 486             RETURN( sym )
 487          END ;
 488          h := headOfConsts
 489       ELSE
 490          h := h^.next
 491       END
 492    END ;
 493    RETURN( sym )
 494 END SkipConst ;
 495
 496
 497 BEGIN
 498    headOfConsts := NIL
 499 *)
 500 BEGIN
 501 END M2Const.