BEGIN
OPEN PasPrivate, PasPrivateVars;
SayScalar:
PUBLIC
PROCEDURE [t: GeneralTypePtr, i: PascalInteger] =
BEGIN
ct: TypePtr ← GetConcreteType[t];
SELECT ct
FROM
integer => SayPascalInteger[i];
char => {SayCh['']; SayCh[PascalIntegerToCh[i]]};
ENDCASE =>
WITH ct
SELECT
FROM
sct: ScalarTypePtr =>
BEGIN
id: IdentifierPtr ← sct.firstId;
WHILE id #
NIL
DO
cidt: REF constant IdentifierTail ← NARROW[id.class];
IF cidt.value = i THEN {SayIdent[id.name]; RETURN};
id𡤌idt.scalarLink;
ENDLOOP;
Error[MalformedScalar];
END;
ENDCASE => Error[MalformedScalar];
END; -- of SayScalar
SayScalarAsInteger:
PUBLIC
PROCEDURE [t: GeneralTypePtr, i: PascalInteger] =
BEGIN
SELECT GetConcreteType[t]
FROM
integer => SayScalar[t, i];
ENDCASE =>
BEGIN
Say["PascalORD["];
SayType[t];
SayCh['[];
SayScalar[t, i];
Say["]]"];
END;
END; -- of SayScalarAsInteger
SayType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr] =
BEGIN
isFirst: BOOLEAN ← TRUE;
SayComma: PROCEDURE = {IF isFirst THEN isFirst ← FALSE ELSE Say[", "]};
SayNameAndType:
PROCEDURE [id: IdentifierPtr] =
BEGIN
SayComma[];
SayIdent[id.name];
WITH id.type
SELECT
FROM
dt: TypePtr => {Say[": "]; SayType[id.type]};
dt: IdentifierPtr => IF dt.class.idClass = type THEN {Say[": "]; SayType[id.type]};
ELSE somebody else will say the type later on
ENDCASE;
END; -- of SayNameAndType
WITH gtp
SELECT
FROM
dgtp:
REF Identifier =>
IF dgtp.class.idClass = type
THEN
SELECT dgtp
FROM
integerId => Say["PascalInteger"];
realId => Say["PascalReal"];
charId => Say["PascalChar"];
booleanId => Say["PascalBoolean"];
stringId => Say["String"];
ENDCASE => SayIdent[dgtp.name]
ELSE SayType[dgtp.type];
dgtp:
REF Type =>
SELECT dgtp
FROM
integer => Say["PascalInteger"];
real => Say["PascalReal"];
char => Say["PascalChar"];
boolean => Say["PascalBoolean"];
string => Say["String"];
ENDCASE =>
-- say its internal structure
WITH dgtp
SELECT
FROM
ddgtp: ScalarTypePtr =>
BEGIN
id: IdentifierPtr ← ddgtp.firstId;
SayCh['{];
UNTIL id =
NIL
DO
cidt: REF constant IdentifierTail ← NARROW[id.class];
SayComma[]; SayIdent[id.name];
id𡤌idt.scalarLink;
ENDLOOP;
SayCh['}];
END;
ddgtp: SubRangeTypePtr =>
BEGIN
SayType[ddgtp.hostType];
SayCh['[];
SayScalar[ddgtp.hostType, ddgtp.lower];
Say[".."];
SayScalar[ddgtp.hostType, ddgtp.upper];
SayCh[']];
END;
ddgtp: PointerTypePtr => {Say[pointerName]; SayType[ddgtp.elType]};
ddgtp: PowerTypePtr =>
BEGIN
SaySetType[ddgtp];
Say[" -- OF "];
SayType[ddgtp.baseType];
Say[" -- "];
END;
ddgtp: ArrayTypePtr =>
BEGIN
IF ddgtp.aIsPacked THEN Say["PACKED "];
Say["ARRAY "];
SayType[ddgtp.aIxType];
Say[" OF "];
SayType[ddgtp.aElType];
END;
ddgtp: ProcArrayTypePtr =>
BEGIN
SayProcArrayIndexType:
PROCEDURE [id: IdentifierPtr] =
{ SayComma[]; Say[id.name]; Say[": "]; SayType[id.type] };
Say["PROCEDURE ["];
isFirst ← TRUE;
EnumerateIdentifierSet[ddgtp.indices, SayProcArrayIndexType];
Say["] RETURNS ["];
Say[varPointerName];
SayType[ddgtp.aElType];
Say["]"];
END;
ddgtp: ComputedSeqArrayTypePtr =>
BEGIN
Say["RECORD[SEQUENCE COMPUTED CARDINAL OF "];
SayType[ddgtp.aElType];
Say["]"];
END;
ddgtp: RecordTypePtr =>
BEGIN
SayFieldList:
PROCEDURE [f: FieldListPtr, depth: PascalInteger ← 1] =
BEGIN
EqualFieldLists:
PROCEDURE [f1, f2: FieldListPtr]
RETURNS [BOOLEAN] =
BEGIN -- this snippet does not show Mesa at its best!
WITH f1
SELECT
FROM
df1:
REF identified FieldList =>
WITH f2
SELECT
FROM
df2: REF identified FieldList => RETURN[df1 = df2];
ENDCASE => RETURN[FALSE];
df1:
REF unidentified FieldList =>
WITH f2
SELECT
FROM
df2: REF unidentified FieldList => RETURN[df1 = df2];
ENDCASE => RETURN[FALSE];
ENDCASE => RETURN[FALSE];
END;
tType: GeneralTypePtr;
v: VariantPtr;
savedIsFirst: BOOLEAN ← isFirst;
isFirst ← TRUE;
EnumerateIdentifierSet[f.fieldSet, SayNameAndType];
IF f.firstVariant #
NIL
THEN
BEGIN
WITH f
SELECT
FROM
df:
REF identified FieldList =>
BEGIN
SayComma[];
SayIdent[df.tagId.name];
Say[": "];
SayType[df.tagId.type];
tType ← df.tagId.type;
END;
df: REF unidentified FieldList => tType ← df.tagType;
ENDCASE;
SayComma[];
Say["x"];
SayPascalInteger[depth];
Say[": "];
Say["SELECT OVERLAID "];
SayType[tType];
Say[" FROM "];
isFirst ← TRUE;
FOR v ← f.firstVariant, v.nextVariant
WHILE v #
NIL
DO
SayComma[];
SayScalar[tType, v.tagValue];
IF v.nextVariant =
NIL
OR
NOT EqualFieldLists[
v.fieldList, v.nextVariant.fieldList] THEN {
Say[": "]; SayFieldList[v.fieldList, depth + 1]};
ENDLOOP;
END;
isFirst ← savedIsFirst;
END; -- of SayFieldList
Say["RECORD["];
SayFieldList[ddgtp.fieldList];
SayCh[']];
END;
ddgtp: FileTypePtr =>
BEGIN
IF IsTextFile[gtp] THEN Say["PascalTextFile"]
ELSE
BEGIN
Say["RECORD[baseFile: PascalFile, element: "];
SayType[ddgtp.fileType];
Say[" ← NULL]"];
END;
END;
ENDCASE; -- on t
ENDCASE; -- on gtp
END; -- of SayType
GetConcreteType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr]
RETURNS [TypePtr] =
BEGIN
DO
IF gtp=NIL THEN Error[UndefinedType];
WITH gtp
SELECT
FROM
dgtp: IdentifierPtr => gtp ← dgtp.type;
dgtp: TypePtr => RETURN[dgtp];
ENDCASE;
ENDLOOP;
END; -- of GetConcreteType
Force:
PROCEDURE [
gtp: GeneralTypePtr,
check:
PROCEDURE [argT: GeneralTypePtr]
RETURNS [is: BOOLEAN, t: GeneralTypePtr]] RETURNS [t: GeneralTypePtr] =
BEGIN
is: BOOLEAN;
[is: is, t: t] ← check[gtp];
IF NOT is THEN Error[UnexpectedType];
END; -- of Force
Is:
PROCEDURE [
gtp: GeneralTypePtr,
check:
PROCEDURE [argT: GeneralTypePtr]
RETURNS [is: BOOLEAN, t: GeneralTypePtr]] RETURNS [BOOLEAN] = {
RETURN[check[gtp].is]};
GenScalarType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr]
RETURNS [GeneralTypePtr] =
{RETURN[Force[gtp, CheckScalarType]]};
IsScalarType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr]
RETURNS [
BOOLEAN] = {
RETURN[Is[gtp, CheckScalarType]]};
CheckScalarType:
PROCEDURE [argT: GeneralTypePtr]
RETURNS [is: BOOLEAN, t: GeneralTypePtr] =
BEGIN
ct: TypePtr;
IF argT # nilGeneralTypePtr
AND (ct ← GetConcreteType[argT]) #
NIL
THEN
WITH ct
SELECT
FROM
dt: SubRangeTypePtr => RETURN[TRUE, dt.hostType];
dt: ScalarTypePtr => RETURN[TRUE, argT];
ENDCASE => NULL;
RETURN[FALSE, nilGeneralTypePtr];
END; -- of CheckScalarType
GenCountableType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr]
RETURNS [GeneralTypePtr] = {RETURN[Force[gtp, CheckCountableType]]};
IsCountableType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr]
RETURNS [
BOOLEAN] = {
RETURN[Is[gtp, CheckCountableType]]};
CheckCountableType:
PROCEDURE [argT: GeneralTypePtr]
RETURNS [is: BOOLEAN, t: GeneralTypePtr] =
BEGIN
ct: TypePtr;
IF argT # nilGeneralTypePtr
AND (ct ← GetConcreteType[argT]) #
NIL
THEN
WITH ct
SELECT
FROM
dt: SubRangeTypePtr => RETURN[TRUE, argT];
dt: ScalarTypePtr => IF ct # real AND ct # string THEN RETURN[TRUE, argT];
ENDCASE => NULL;
RETURN[FALSE, nilGeneralTypePtr];
END; -- of CheckCountableType
GenCountableHostType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr]
RETURNS [GeneralTypePtr] = {RETURN[Force[gtp, CheckCountableHostType]]};
IsCountableHostType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr]
RETURNS [
BOOLEAN] =
{RETURN[Is[gtp, CheckCountableHostType]]};
CheckCountableHostType:
PROCEDURE [argT: GeneralTypePtr]
RETURNS [is: BOOLEAN, t: GeneralTypePtr] =
BEGIN
ct: TypePtr;
[is, t] ← CheckCountableType[argT];
IF NOT is THEN RETURN;
ct ← GetConcreteType[t];
WITH ct
SELECT
FROM
dt: ScalarTypePtr => RETURN[TRUE, t];
dt: SubRangeTypePtr => RETURN[TRUE, dt.hostType];
ENDCASE;
END; -- of CheckCountableHostType
GenFiniteType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr]
RETURNS [t: GeneralTypePtr, lower, upper: PascalInteger] =
BEGIN
tp: TypePtr;
t ← GenCountableType[gtp];
tp ← GetConcreteType[t];
WITH tp
SELECT
FROM
dt: ScalarTypePtr => IF tp # integer THEN RETURN[t, 0, dt.size - 1];
dt: SubRangeTypePtr => RETURN[GenCountableHostType[t], dt.lower, dt.upper];
ENDCASE => NULL;
Error[NotFiniteType];
END; -- of GenFiniteType
IsFiniteType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr]
RETURNS [
BOOLEAN] = {
RETURN[GetCountableType[gtp] # integer]};
CheckForPascalString:
PUBLIC
PROCEDURE [t: GeneralTypePtr]
RETURNS [is: BOOLEAN, length: PascalInteger] =
BEGIN
ct: TypePtr ← GetConcreteType[t];
IF ct = string THEN RETURN[is: TRUE, length: -1];
WITH ct
SELECT
FROM
at: ArrayTypePtr =>
IF at.aIsPacked
AND IsFiniteType[at.aIxType]
AND IsFiniteType[at.aElType]
THEN
BEGIN
it: TypePtr;
lower, upper: PascalInteger;
[it, lower, upper] ← GetFiniteType[at.aIxType];
IF GetCountableType[at.aElType] = char
AND lower <= upper
THEN RETURN[is: TRUE, length: upper-lower+1];
END;
ENDCASE => NULL;
RETURN[is: FALSE, length: 0];
END; -- of CheckForPascalString
PowerSetOf:
PUBLIC
PROCEDURE [t: GeneralTypePtr]
RETURNS [GeneralTypePtr] =
BEGIN
pt: TypePtr ← Z.NEW[Type←[power[baseType: t]]];
RETURN[pt];
END; -- of PowerSetOf
IsTextFile:
PUBLIC
PROCEDURE [t: GeneralTypePtr]
RETURNS [
BOOLEAN] =
BEGIN
ct: TypePtr ← GetConcreteType[t];
WITH ct
SELECT
FROM
ft: FileTypePtr => IF GetConcreteType[ft.fileType] = char THEN RETURN[TRUE];
ENDCASE => NULL;
RETURN[FALSE];
END; -- of IsTextFile
TranslateIdList:
PUBLIC
PROCEDURE [pset: IdentifierSetPtr ←
NIL] =
BEGIN -- sy=identSy
TranslateIdInList:
PROCEDURE =
BEGIN
new: IdentifierPtr;
IF sy # identSy THEN Error[MalformedIdList];
new ← NewIdent[pset: pset];
SayIdent[ident];
InSymbol[];
END; -- of TranslateIdInList
InitIdentifierSet[pset];
SequenceOf[TranslateIdInList, commaSy];
END; -- TranslateIdList
TranslateVariableList:
PUBLIC
PROCEDURE [
pset: IdentifierSetPtr ← NIL, fwdOK: BOOLEAN ← FALSE] =
BEGIN -- sy=identSy
MarkAsNormalIdentifier:
PROCEDURE [id: IdentifierPtr] = {
id.class ← Z.NEW[IdentifierTail←[variable[kind: normal]]]};
setPtr: IdentifierSetPtr𡤌reateIdentifierSet[];
TranslateIdList[pset: setPtr];
MustBe[colonSy, ":", MalformedIdList];
AssignTypeToIdSet[pset: setPtr, type: TranslateType[fwdOK: fwdOK]];
EnumerateIdentifierSet[setPtr, MarkAsNormalIdentifier];
MergeIdentifierSets[into: pset, from: setPtr];
END; -- TranslateVariableList
TranslateSimpleType:
PROCEDURE [id: IdentifierPtr ←
NIL, fwdOK:
BOOLEAN]
RETURNS [GeneralTypePtr] =
BEGIN
SELECT sy
FROM
lParentSy =>
BEGIN
set: IdentifierSetPtr ← CreateIdentifierSet[];
isFirst: BOOLEAN ← TRUE;
lastId: ConstantIdentifierTailPtr ← NIL;
nextElementValue: CARDINAL ← 0;
t: ScalarTypePtr;
SpecifyElementValue:
PROCEDURE [id: IdentifierPtr] =
BEGIN
cTail: ConstantIdentifierTailPtr←
Z.
NEW[constant IdentifierTail←
[constant[scalarLink: NIL, value: nextElementValue]]];
id.class ← cTail;
IF isFirst
THEN {t.firstId ← id; isFirst ←
FALSE}
ELSE lastId.scalarLink ← id;
lastId ← cTail;
nextElementValue ← nextElementValue + 1;
END;
MustBe[lParentSy, "{", MalformedSimpleType];
TranslateIdList[pset: set];
MustBe[rParentSy, "}", MalformedSimpleType];
t←Z.NEW[scalar Type←[scalar[firstId: NIL, size: 0]]];
AssignTypeToIdSet[
pset: set,
type: IF id # NIL THEN id ELSE t];
EnumerateIdentifierSet[set, SpecifyElementValue];
t.size ← nextElementValue;
MergeIdentifierSets[from: set];
RETURN[t];
END;
identSy, addOpSy, intConstSy, stringConstSy =>
BEGIN
c: ScalarConstantValuePtr;
cTail: ScalarConstantValueTailPtr;
t: SubRangeTypePtr;
IF sy = identSy
THEN
BEGIN
we have a type identifier or a named constant starting a subrange
id: IdentifierPtr ← IdentLookup[couldFail: fwdOK];
IF id #
NIL
THEN
WITH id.class
SELECT
FROM
didt: REF type IdentifierTail => SayType[id];
ENDCASE => GOTO TryConstant
ELSE
-- hasn't been declared yet, plan on somebody later doing it
BEGIN
id ← NewIdent[];
id.type ← nilGeneralTypePtr;
id.class ← Z.NEW[type IdentifierTail←[type[]]];
SayIdent[ident];
END;
InSymbol[];
RETURN[id]
EXITS TryConstant => NULL;
END;
c ← ParseCountableConstant[]; -- subrange a..b
cTail ← NARROW[c.value];
SayType[c.type];
SayCh['[];
SayTranslation[c];
t ← Z.NEW[subRange Type←[subRange[hostType: c.type, lower: cTail.v.value, upper: NULL]]];
IF sy # colonSy THEN Error[MalformedRangeType];
Say[".."];
InSymbol[];
c ← ParseCountableConstant[];
cTail ← NARROW[c.value];
SayTranslation[c];
SayCh[']];
IF t.hostType # c.type THEN Error[MalformedRangeType];
t.upper ← cTail.v.value;
RETURN[t];
END;
ENDCASE => Error[MalformedSimpleType];
RETURN[nilGeneralTypePtr]; -- never gets here
END; -- of TranslateSimpleType
TranslateType:
PUBLIC
PROCEDURE [
id: IdentifierPtr ← NIL,
fwdOK: BOOLEAN ← FALSE,
packArrays: BOOLEAN ← FALSE,
outerArrayIsFunny: ArrayDifferentlyMethod ← notAtAll] RETURNS [GeneralTypePtr] =
BEGIN
TranslateArrayTail:
PROCEDURE [packIt:
BOOL ←
FALSE]
RETURNS [GeneralTypePtr] =
BEGIN -- sy=lBrackSy or commaSy
aTP: ArrayTypePtr;
IF packIt THEN Say["PACKED "];
Say["ARRAY "];
InSymbol[];
aTP ←
Z.
NEW[array Type←
[array[aIxType: TranslateSimpleType[fwdOK: fwdOK],
aElType: nilGeneralTypePtr,
aIsPacked: packIt]]];
SELECT sy
FROM
commaSy => {Say[" OF "]; aTP.aElType ← TranslateArrayTail[packIt]};
rBrackSy =>
BEGIN
InSymbol[];
MustBe[ofSy, " OF ", MalformedType];
aTP.aElType ← TranslateType[fwdOK: fwdOK];
END;
ENDCASE => Error[MalformedType];
RETURN[aTP];
END; -- of TranslateArrayTail
TranslateFieldList:
PROCEDURE [depth: PascalInteger ← 1]
RETURNS [FieldListPtr] =
BEGIN -- sy=identSy
last, firstThisType, lastThisType, id: IdentifierPtr ← NIL;
tagId: IdentifierPtr;
gtp: GeneralTypePtr;
lastVariant: VariantPtr ← NIL;
commaAfterLastField: BOOLEAN ← FALSE;
fL: FieldListPtr ← Z.NEW[unidentified FieldList];
TranslateVariant:
PROCEDURE =
BEGIN
first, last, v: VariantPtr ← NIL;
tagType: TypePtr ← GetConcreteType[gtp];
vFL: FieldListPtr;
TranslateVariantTag:
PROCEDURE =
BEGIN
v: VariantPtr;
c: ScalarConstantValuePtr ← ParseCountableConstant[];
cTail: ScalarConstantValueTailPtr ← NARROW[c.value];
cType: TypePtr ← GetConcreteTypeOfValue[c];
SayTranslation[c];
WITH tagType
SELECT
FROM
t: ScalarTypePtr => IF cType # tagType THEN Error[MalformedType];
t: SubRangeTypePtr =>
IF cType # GetConcreteType[t.hostType]
OR cTail.v.value < t.lower
OR
cTail.v.value > t.upper THEN Error[MalformedType];
ENDCASE => Error[MalformedType];
v ← Z.NEW[Variant←[nextVariant: NIL, tagValue: cTail.v.value, fieldList: NIL]];
IF first = NIL THEN first ← v ELSE last.nextVariant ← v;
last ← v;
END; -- of TranslateVariantTag
SequenceOf[TranslateVariantTag, commaSy];
MustBe[colonSy, "=>", MalformedType];
MustBe[lParentSy, "[", MalformedType];
vFL ← TranslateFieldList[depth + 1];
MustBe[rParentSy, "]", MalformedType];
FOR v ← first, v.nextVariant UNTIL v = NIL DO v.fieldList ← vFL; ENDLOOP;
IF fL.firstVariant = NIL THEN fL.firstVariant ← first
ELSE lastVariant.nextVariant ← first;
lastVariant ← last;
END; -- of TranslateVariant
TranslateField:
PROCEDURE = {
IF sy # caseSy
THEN
TranslateVariableList[pset: fL.fieldSet, fwdOK: fwdOK]
ELSE commaAfterLastField ← TRUE};
fL.fieldSet𡤌reateIdentifierSet[];
IF sy # identSy AND sy # caseSy THEN RETURN[fL]; -- empty is OK
IF sy = identSy
THEN
BEGIN
SequenceOf[TranslateField, semiColonSy, ","];
IF sy = caseSy AND NOT commaAfterLastField THEN SayCh[',];
END;
IF sy # caseSy THEN RETURN[fL];
InSymbol;
IF sy # identSy THEN Error[MalformedType];
There follows a small hack. In either legal case we must recover
the identifier and use it either as a field or as a type, but
we don't yet know which. Fortunately the scanner does not
modify PasVars.ident except when it sees a new identifier,
so we can get the effect of a one-symbol look-ahead
by simply re-loading PasVars.sy with the constant identSy.
InSymbol;
SELECT sy
FROM
colonSy =>
BEGIN
newfL: FieldListPtr;
sy ← identSy;
SayIdent[ident];
SayCh[':];
tagId ← NewIdent[pset: fL.fieldSet];
uses left-over ident string. colonSy didn't change it.
tagId.class ← Z.NEW[IdentifierTail←[variable[kind: normal]]];
Now, fL should have been identified, not unidentified!
So, allocate a new one and copy the fields:
newfL ←
Z.
NEW[FieldList←[fieldSet: fL.fieldSet,
firstVariant: fL.firstVariant,
tagSpecific: identified[tagId: tagId]]];
fL ← newfL;
InSymbol;
IF sy # identSy THEN Error[MalformedType];
gtp ← TranslateSimpleType[fwdOK: fwdOK];
tagId.type ← gtp;
Say[", x"];
SayPascalInteger[depth];
Say[": SELECT OVERLAID "];
SayType[gtp];
Say[" FROM "];
MustBe[ofSy, "", MalformedType];
END;
ofSy =>
BEGIN
sy ← identSy;
Say["x"];
SayPascalInteger[depth];
Say[": SELECT OVERLAID "];
gtp ← TranslateSimpleType[fwdOK: fwdOK];
Say[" FROM "];
NARROW[fL, REF unidentified FieldList].tagType ← gtp;
END;
ENDCASE => Error[MalformedType];
SequenceOf[TranslateVariant, semiColonSy, ","];
Say[", ENDCASE"];
RETURN[fL];
END; -- of TranslateFieldList
SELECT sy FROM
arrowSy =>
BEGIN
tP: PointerTypePtr;
InSymbol[];
Say[pointerName];
tP ← Z.NEW[pointer Type←[pointer[elType: TranslateType[fwdOK: fwdOK]]]];
RETURN[tP];
END;
setSy =>
BEGIN
q: OutputQueuePtr;
t: GeneralTypePtr;
InSymbol[];
MustBe[ofSy, "", MalformedType];
PushOut[];
t ← PowerSetOf[TranslateSimpleType[fwdOK: fwdOK]];
q ← CopyAndPopOut[];
SaySetType[GetConcreteType[t]];
Say[" -- OF "];
MergeQueue[from: q];
Say[" -- "];
RETURN[t];
END;
packedSy =>
BEGIN
q: OutputQueuePtr;
gtp: GeneralTypePtr;
InSymbol[];
PushOut[];
gtp ← TranslateType[fwdOK: fwdOK, packArrays:
TRUE,
outerArrayIsFunny: outerArrayIsFunny];
q ← CopyAndPopOut[];
WITH gtp
SELECT
FROM
dgtp:
REF array Type =>
IF NOT dgtp.aIsPacked THEN Error[Confusion];
dgtp:
REF procArray Type =>
NULL;
dgtp:
REF computedSeqArray Type =>
Error[MalformedType]; -- because
computedSeq arrays only make sense if elType takes more than one word
dgtp:
REF record Type =>
IF dgtp.recIsPacked THEN Error[MalformedType]
ELSE {Say[" -- PACKED -- "]; dgtp.recIsPacked ← TRUE};
dgtp:
REF file Type =>
IF dgtp.fileIsPacked THEN Error[MalformedType]
ELSE dgtp.fileIsPacked ← TRUE;
ENDCASE => Error[MalformedType];
MergeQueue[q];
RETURN[gtp];
END;
arraySy =>
BEGIN
InSymbol;
IF sy # lBrackSy THEN Error[MalformedType];
SELECT outerArrayIsFunny FROM
procArray =>
BEGIN
TranslateProcArrayIndex:
PROCEDURE =
BEGIN
id: IdentifierPtr;
curOrdinal ← curOrdinal + 1;
id ← NewIdent[ordinalNames[curOrdinal], aTP.indices];
Say[id.name]; Say[": "];
id.type ← TranslateSimpleType[fwdOK: fwdOK];
END;
Ordinal: TYPE = [1..10];
curOrdinal: INT ← 0;
ordinalNames:
ARRAY Ordinal
OF
ROPE =
["First", "Second", "Third", "Fourth", "Fifth",
"Sixth", "Seventh", "Eighth", "Ninth", "Tenth"];
aTP: ProcArrayTypePtr;
Say["PROCEDURE ["];
InSymbol[]; -- digest the left bracket
aTP ←
Z.
NEW[procArray Type←
[procArray[aElType: nilGeneralTypePtr, indices: CreateIdentifierSet[]]]];
SequenceOf[TranslateProcArrayIndex, commaSy, ", "];
MustBe[rBrackSy, "]", MalformedType];
MustBe[ofSy, " RETURNS [Result: ", MalformedType];
Say[varPointerName];
aTP.aElType ← TranslateType[fwdOK: fwdOK];
Say["]"];
RETURN[aTP];
END;
computedSeqArray =>
BEGIN
aTP: ComputedSeqArrayTypePtr ←
Z.
NEW[computedSeqArray Type←
[computedSeqArray[aElType: nilGeneralTypePtr]]];
InSymbol[]; -- digest the left bracket
PushOut[]; --prepare to throw away the index type
IF
NOT IsScalarType[TranslateSimpleType[fwdOK: fwdOK]]
THEN
Error[MalformedComputedSeqArrayDeclaration];
PopOut[]; --there it went!
MustBe[rBrackSy, "RECORD[SEQUENCE COMPUTED CARDINAL OF", MalformedComputedSeqArrayDeclaration];
MustBe[ofSy, "", MalformedComputedSeqArrayDeclaration];
aTP.aElType ← TranslateType[fwdOK: fwdOK];
Say["]"];
RETURN[aTP];
END
ENDCASE => RETURN[TranslateArrayTail[packIt: packArrays]];
END;
recordSy =>
BEGIN
tP: RecordTypePtr;
Say["RECORD ["];
InSymbol;
tP ← Z.NEW[record Type ←[record[fieldList: TranslateFieldList[]]]];
MustBe[endSy, "]", MalformedType];
RETURN[tP];
END;
fileSy =>
BEGIN
tP: FileTypePtr;
q: OutputQueuePtr;
InSymbol[];
MustBe[ofSy, "", MalformedType];
PushOut[];
tP ← Z.NEW[file Type←[file[fileType: TranslateType[fwdOK: fwdOK]]]];
q ← CopyAndPopOut[];
IF IsTextFile[tP]
THEN
BEGIN Say["PascalTextFile"]; ClearQueue[q]; END
ELSE
BEGIN
Say["RECORD[baseFile: PascalFile, element: "];
MergeQueue[from: q];
Say[" ← NULL]"]
END;
RETURN[tP];
END;
ENDCASE => RETURN[TranslateSimpleType[id: id, fwdOK: fwdOK]];
END; -- of TranslateType
SaySetType:
PUBLIC
PROCEDURE [t: TypePtr] =
BEGIN
WITH t
SELECT
FROM
dt: PowerTypePtr =>
BEGIN
lower, upper: PascalInteger;
st: TypePtr;
[st, lower, upper] ← GetFiniteType[dt.baseType];
SELECT upper - lower
FROM
< 16 => Say["PascalSmallSet"];
< 64 => Say["PascalMediumSet"];
< 256 => Say["PascalLargeSet"];
ENDCASE => Error[SetTooLarge];
END;
ENDCASE => Error[NotASet];
END; -- of SaySetType
SaySetOriginOffset:
PUBLIC
PROCEDURE [baseType: GeneralTypePtr] =
BEGIN
lower, upper: PascalInteger;
st: GeneralTypePtr;
[st, lower, upper] ← GenFiniteType[baseType];
IF lower = 0 THEN RETURN;
SayCh['-];
SayScalarAsInteger[st, lower];
END; -- of SaySetOriginOffset
DisposeType:
PUBLIC
PROCEDURE [gtp: GeneralTypePtr] =
BEGIN
NULL; -- I tried sticking in some FREE[@. . .], but the compiler complained
END; -- of DisposeType
DisposeFieldList:
PROCEDURE [fl: FieldListPtr] =
BEGIN
NULL;
END; -- of DisposeFieldList
END. -- of PasType --