* Copyright (c) 1983 The Regents of the University of California.
* %sccs.include.redist.c%
static char sccsid
[] = "@(#)modula-2.c 5.4 (Berkeley) %G%";
* Modula-2 specific symbol routines.
private boolean initialized
;
((t)->class == RANGE and istypename((t)->type, "char")) \
* Initialize Modula-2 information.
mod2
= language_define("modula-2", ".mod");
language_setop(mod2
, L_PRINTDECL
, modula2_printdecl
);
language_setop(mod2
, L_PRINTVAL
, modula2_printval
);
language_setop(mod2
, L_TYPEMATCH
, modula2_typematch
);
language_setop(mod2
, L_BUILDAREF
, modula2_buildaref
);
language_setop(mod2
, L_EVALAREF
, modula2_evalaref
);
language_setop(mod2
, L_MODINIT
, modula2_modinit
);
language_setop(mod2
, L_HASMODULES
, modula2_hasmodules
);
language_setop(mod2
, L_PASSADDR
, modula2_passaddr
);
* Typematch tests if two types are compatible. The issue
* is a bit complicated, so several subfunctions are used for
* various kinds of compatibility.
private boolean
builtinmatch (t1
, t2
)
t2
== t_int
->type
and t1
->class == RANGE
and
istypename(t1
->type
, "integer") or
istypename(t1
->type
, "cardinal")
t1
->class == RANGE
and istypename(t1
->type
, "char")
istypename(t1
->type
, "real") or
istypename(t1
->type
, "longreal")
t2
== t_boolean
->type
and
t1
->class == RANGE
and istypename(t1
->type
, "boolean")
private boolean
nilMatch (t1
, t2
)
(t1
== t_nil
and t2
->class == PTR
) or
(t1
->class == PTR
and t2
== t_nil
)
private boolean
enumMatch (t1
, t2
)
(t1
->class == SCAL
and t2
->class == CONST
and t2
->type
== t1
) or
(t1
->class == CONST
and t2
->class == SCAL
and t1
->type
== t2
)
private boolean
openArrayMatch (t1
, t2
)
t1
->class == OPENARRAY
and t1
->symvalue
.ndims
== 1 and
compatible(rtype(t2
->chain
)->type
, t_int
) and
compatible(t1
->type
, t2
->type
)
t2
->class == OPENARRAY
and t2
->symvalue
.ndims
== 1 and
compatible(rtype(t1
->chain
)->type
, t_int
) and
compatible(t1
->type
, t2
->type
)
private boolean
isConstString (t
)
t
->language
== primlang
and t
->class == ARRAY
and t
->type
== t_char
private boolean
stringArrayMatch (t1
, t2
)
t2
->class == ARRAY
and compatible(t2
->type
, t_char
->type
)
t1
->class == ARRAY
and compatible(t1
->type
, t_char
->type
)
public boolean
modula2_typematch (type1
, type2
)
if (t1
== t_char
->type
or t1
== t_int
->type
or
t1
== t_real
->type
or t1
== t_boolean
->type
nilMatch(t1
, t2
) or enumMatch(t1
, t2
) or
openArrayMatch(t1
, t2
) or stringArrayMatch(t1
, t2
)
public modula2_printdecl (s
)
if (s
->class == TYPEREF
) {
if (s
->type
->class == SCAL
) {
printf("enumeration constant with value ");
eval(s
->symvalue
.constval
);
printf("const %s = ", symname(s
));
eval(s
->symvalue
.constval
);
printf("type %s = ", symname(s
));
printtype(s
, s
->type
, 0);
printf("type %s", symname(s
));
printf("(parameter) %s : ", symname(s
));
printf("var %s : ", symname(s
));
printtype(s
, s
->type
, 0);
printf("(var parameter) %s : ", symname(s
));
printtype(s
, s
->type
, 0);
printf("(function variable) %s : ", symname(s
));
printtype(s
, s
->type
, 0);
printf("(field) %s : ", symname(s
));
printtype(s
, s
->type
, 0);
printf("procedure %s", symname(s
));
printf("program %s", symname(s
));
printf("procedure %s", symname(s
));
printtype(s
, s
->type
, 0);
printf("module %s", symname(s
));
printf("[%s]", classname(s
));
* Recursive whiz-bang procedure to print the type portion
* The symbol associated with the type is passed to allow
* searching for type names without getting "type blah = blah".
private printtype (s
, t
, n
)
if (t
->class == TYPEREF
) {
panic("printtype: class %s", classname(t
));
printtype(t
, t
->type
, n
);
for (i
= 1; i
< t
->symvalue
.ndims
; i
++) {
printtype(t
, t
->type
, n
);
for (i
= 1; i
< t
->symvalue
.ndims
; i
++) {
printtype(t
, t
->type
, n
);
for (i
= 1; i
< t
->symvalue
.ndims
; i
++) {
printtype(t
, t
->type
, n
);
printtype(t
->chain
, t
->chain
, n
);
printf("\t%s : ", symname(t
));
printtype(t
, t
->type
, n
);
printtype(t
, t
->type
, n
);
if (t
->name
!= nil
and ident(t
->name
)[0] != '\0') {
printtype(t
, t
->type
, n
);
printtype(t
, t
->type
, n
);
printf("[%s]", classname(t
));
* Print out a record declaration.
private printRecordDecl (t
, n
)
for (f
= t
->chain
; f
!= nil
; f
= f
->chain
) {
printf("%s : ", symname(f
));
printtype(f
->type
, f
->type
, n
+4);
* Print out the declaration of a range type.
private printRangeDecl (t
)
r0
= t
->symvalue
.rangev
.lower
;
r1
= t
->symvalue
.rangev
.upper
;
if (r0
< 0x20 or r0
> 0x7e) {
printf("'%c'..", (char) r0
);
if (r1
< 0x20 or r1
> 0x7e) {
printf("'%c'", (char) r1
);
} else if (r0
> 0 and r1
== 0) {
printf("%ld byte real", r0
);
printf("%lu..%lu", r0
, r1
);
printf("%ld..%ld", r0
, r1
);
* Print out an enumeration declaration.
private printEnumDecl (e
, n
)
printf("%s", symname(t
));
printf(", %s", symname(t
));
* List the parameters of a procedure or function.
* No attempt is made to combine like types.
for (t
= s
->chain
; t
!= nil
; t
= t
->chain
) {
panic("unexpected class %d for parameter", t
->class);
printf("%s", symname(t
));
printtype(t
, t
->type
, 0);
* Test if a pointer type should be treated as a null-terminated string.
* The type given is the type that is pointed to.
private boolean
isCstring (type
)
t
->class == RANGE
and istypename(a
->type
, "char") and
(t
->symvalue
.rangev
.upper
- t
->symvalue
.rangev
.lower
+ 1) <= 0
* Modula 2 interface to printval.
public modula2_printval (s
)
* Print out the value on the top of the expression stack
* in the format for the type of the given symbol, assuming
* the size of the object is n bytes.
if (s
->class == TYPEREF
) {
printf("\"%.*s\"", len
, sp
);
* Unresolved opaque type.
} else if (isCstring(s
->type
)) {
if (ord(s
->class) < ord(BADUSE
) or ord(s
->class) > ord(TYPEREF
)) {
panic("printval: bad class %d", ord(s
->class));
printf("[%s]", classname(s
));
* Print out a dynamic array.
private Address
printDynSlice();
private printDynarray (t
)
sp
-= (t
->symvalue
.ndims
* sizeof(Word
));
if (t
->symvalue
.ndims
== 0) {
printf("[dynarray @nocount]");
n
= ((long *) sp
)[-(t
->symvalue
.ndims
)];
base
= printDynSlice(base
, n
, t
->symvalue
.ndims
, eltype
, size(eltype
));
* Print out one dimension of a multi-dimension dynamic array.
* Return the address of the element that follows the printed elements.
private Address
printDynSlice (base
, count
, ndims
, eltype
, elsize
)
n
= ((long *) sp
)[-ndims
+ 1];
if (ndims
== 1 and ischar(eltype
)) {
slice
= newarr(char, count
);
printf("\"%.*s\"", count
, slice
);
for (i
= 0; i
< count
; i
++) {
slice
= newarr(char, elsize
);
b
= printDynSlice(b
, n
, ndims
- 1, eltype
, elsize
);
private printSubarray (t
)
* Print out the value of a scalar (non-enumeration) type.
private printrange (s
, n
)
if (s
->symvalue
.rangev
.upper
== 0 and s
->symvalue
.rangev
.lower
> 0) {
if (n
== sizeof(float)) {
} else if (t
->class == RANGE
) {
panic("expected range or enumerated base type for set");
* Print out a set of an enumeration.
private printSetOfEnum (t
)
register integer i
, j
, *p
;
printf("%s", symname(e
));
printf(", %s", symname(e
));
if (j
>= sizeof(integer
)*BITSPERBYTE
) {
* Print out a set of a subrange type.
private printSetOfRange (t
)
register integer i
, j
, *p
;
v
= t
->symvalue
.rangev
.lower
;
while (v
<= t
->symvalue
.rangev
.upper
) {
if (j
>= sizeof(integer
)*BITSPERBYTE
) {
* Construct a node for subscripting a dynamic or subarray.
* The list of indices is left for processing in evalaref,
* unlike normal subscripting in which the list is expanded
* across individual INDEX nodes.
private Node
dynref (a
, t
, slist
)
if (not compatible(p
->value
.arg
[0]->nodetype
, t_int
)) {
suberror("subscript \"", p
->value
.arg
[0], "\" is the wrong type");
if (n
> t
->symvalue
.ndims
and (t
->symvalue
.ndims
!= 0 or n
!= 1)) {
suberror("too many subscripts for ", a
, nil
);
} else if (n
< t
->symvalue
.ndims
) {
suberror("not enough subscripts for ", a
, nil
);
r
= build(O_INDEX
, a
, slist
);
r
->nodetype
= rtype(t
->type
);
* Construct a node for subscripting.
public Node
modula2_buildaref (a
, slist
)
while (p
!= nil
and t
!= nil
) {
if (not compatible(rtype(t
), rtype(esub
->nodetype
))) {
suberror("subscript \"", esub
, "\" is the wrong type");
r
= build(O_INDEX
, r
, esub
);
suberror("too many subscripts for ", a
, nil
);
suberror("not enough subscripts for ", a
, nil
);
suberror("\"", a
, "\" is not an array");
* Subscript usage error reporting.
private suberror (s1
, e1
, s2
)
* Check that a subscript value is in the appropriate range.
private subchk (value
, lower
, upper
)
long value
, lower
, upper
;
if (value
< lower
or value
> upper
) {
error("subscript value %d out of range [%d..%d]", value
, lower
, upper
);
* Compute the offset for subscripting a dynamic array.
private getdynoff (ndims
, sub
)
for (k
= 0; k
< ndims
- 1; k
++) {
subchk(sub
[k
], 0, count
[k
] - 1);
off
+= (sub
[k
] * count
[k
+1]);
subchk(sub
[ndims
- 1], 0, count
[ndims
- 1] - 1);
return off
+ sub
[ndims
- 1];
* Compute the offset associated with a subarray.
private getsuboff (ndims
, sub
)
info
= (struct subarrayinfo
*) sp
;
for (k
= 0; k
< ndims
; k
++) {
subchk(sub
[k
], 0, info
[k
].count
- 1);
off
+= sub
[k
] * info
[k
].mult
;
* Evaluate a subscript index.
public modula2_evalaref (s
, base
, i
)
findbounds(rtype(t
->chain
), &lb
, &ub
);
error("subscript %d out of range [%d..%d]", i
, lb
, ub
);
push(long, base
+ (i
- lb
) * size(t
->type
));
} else if ((t
->class == OPENARRAY
or t
->class == DYNARRAY
) and
push(long, base
+ i
* size(t
->type
));
} else if (t
->class == OPENARRAY
or t
->class == DYNARRAY
or
sub
= (long *) (sp
- (t
->symvalue
.ndims
* sizeof(long)));
sp
-= (t
->symvalue
.ndims
* sizeof(long));
if (t
->class == SUBARRAY
) {
off
= getsuboff(t
->symvalue
.ndims
, sub
);
off
= getdynoff(t
->symvalue
.ndims
, sub
);
push(long, b
+ off
* size(t
->type
));
error("[internal error: expected array in evalaref]");
* Initial Modula-2 type information.
private Symbol inittype
[NTYPES
+ 1];
private addType (n
, s
, lower
, upper
)
panic("initial Modula-2 type number too large for '%s'", s
);
t
= insert(identname(s
, true));
t
->type
= newSymbol(nil
, 0, RANGE
, t
, nil
);
t
->type
->symvalue
.rangev
.lower
= lower
;
t
->type
->symvalue
.rangev
.upper
= upper
;
t
->type
->language
= mod2
;
addType(1, "integer", 0x80000000L
, 0x7fffffffL
);
addType(2, "char", 0L, 255L);
addType(3, "boolean", 0L, 1L);
addType(4, "unsigned", 0L, 0xffffffffL
);
addType(5, "real", 4L, 0L);
addType(6, "longreal", 8L, 0L);
addType(7, "word", 0L, 0xffffffffL
);
addType(8, "byte", 0L, 255L);
addType(9, "address", 0L, 0xffffffffL
);
addType(10, "file", 0L, 0xffffffffL
);
addType(11, "process", 0L, 0xffffffffL
);
addType(12, "cardinal", 0L, 0x7fffffffL
);
public modula2_modinit (typetable
)
for (i
= 1; i
<= NTYPES
; i
++) {
typetable
[i
] = inittype
[i
];
public boolean
modula2_hasmodules ()
public boolean
modula2_passaddr (param
, exprtype
)