BEGIN
OPEN PasPrivate, PasPrivateVars;
K: INT = 1024;
Precision:
TYPE = {short, long, other};
short means a value of subrange of integer,
long means an integer,
other is anything else.
ArithLen:
TYPE =
RECORD [
p: Precision,
lower: INT ← 0, -- if short, then the best lower bound that I know on the value
upper: INT ← 0]; -- same for best upper bound
TranslateVariable:
PUBLIC
PROCEDURE [isLHS:
BOOLEAN ←
FALSE]
RETURNS [ValuePtr] =
BEGIN v: ValuePtr ← ParseVariable[isLHS]; SayTranslation[v]; RETURN[v]; END;
of TranslateVariable
ParseVariable:
PUBLIC
PROCEDURE [isLHS:
BOOLEAN ←
FALSE]
RETURNS [ValuePtr] =
BEGIN
ParseVariableWorker:
PUBLIC
PROCEDURE
RETURNS [GeneralTypePtr] =
BEGIN
id: IdentifierPtr;
gtp: GeneralTypePtr;
t: TypePtr;
IF sy # identSy THEN Error[MalformedVariable];
id ← IdentLookup[];
WITH id.class
SELECT
FROM
vid: VariableIdentifierTailPtr =>
BEGIN
gtp ← id.type;
t ← GetConcreteType[gtp];
SayIdent[id.name];
IF vid.kind = var THEN SayCh['^];
InSymbol[];
DO
WITH t
SELECT
FROM
st: ScalarTypePtr => RETURN[gtp]; -- variable has no structure
sRt: SubRangeTypePtr => RETURN[gtp]; -- variable has no structure
pt: PowerTypePtr => RETURN[gtp]; -- variable has no structure
pt: PointerTypePtr =>
IF CouldBe[arrowSy, "^"] THEN gtp ← pt.elType ELSE RETURN[gtp];
at: ArrayTypePtr =>
BEGIN
IF at.aIsDynamic THEN SayCh['^];
IF CouldBe[lBrackSy, ""]
THEN
BEGIN
SayCh['[];
[] ← TranslateExpression[at.aIxType];
SayCh[']];
gtp ← at.aElType;
IF sy = commaSy THEN sy ← lBrackSy
ELSE MustBe[rBrackSy, "", MalformedArrayAccess];
END
ELSE RETURN[gtp];
END;
at: ComputedSeqArrayTypePtr =>
BEGIN
SayCh['^];
IF CouldBe[lBrackSy, ""]
THEN
BEGIN
SayCh['[];
[] ← TranslateExpression[integer];
SayCh[']];
gtp ← at.aElType;
MustBe[rBrackSy, "", MalformedComputedSeqArrayAccess];
END
ELSE RETURN[gtp];
END;
at: ProcArrayTypePtr =>
BEGIN
ParseProcArrayIndex:
PROC [id: IdentifierPtr] =
{[] ← TranslateExpression[id.type]; [] ← CouldBe[commaSy, ", "]};
MustBe[lBrackSy, "[", MalformedProcArrayAccess];
EnumerateIdentifierSet[pset: at.indices, p: ParseProcArrayIndex];
MustBe[rBrackSy, "]^", MalformedProcArrayAccess];
gtp ← at.aElType;
END;
rt: RecordTypePtr =>
BEGIN
IF CouldBe[periodSy, "."]
THEN
BEGIN
IF sy # identSy THEN Error[MalformedRecordAccess];
SayIdent[ident];
InSymbol[];
id ← IdentLookup[pfl: rt.fieldList];
IF id = NIL THEN Error[MalformedRecordAccess];
gtp ← id.type;
END
ELSE RETURN[gtp];
END;
ft: FileTypePtr =>
IF CouldBe[arrowSy, ""]
THEN {
IF NOT isLHS AND IsTextFile[gtp] THEN CompileTextRead[]
ELSE Say[".element"];
gtp ← ft.fileType}
ELSE RETURN[gtp];
ENDCASE => Error[MalformedVariable];
t ← GetConcreteType[gtp];
ENDLOOP;
END;
ENDCASE => RETURN[nilGeneralTypePtr];
END; -- of ParseVariableWorker
CompileTextRead:
PROCEDURE =
BEGIN
q: OutputQueuePtr ← CopyAndPopOut[];
PushOut[];
Say["PascalTextElement[file: @"];
MergeQueue[from: q];
SayCh[']];
END; -- of CompileTextRead
gtp: GeneralTypePtr;
PushOut[];
gtp ← ParseVariableWorker[];
RETURN[
Z.
NEW[Value←[type: gtp, value:
Z.
NEW[ValueTail ←
[variable[translation: CopyAndPopOut[]]]]]]];
END; -- of ParseVariable
GetArithLen:
PROCEDURE [v: ValuePtr]
RETURNS [a: ArithLen] =
BEGIN
ct: TypePtr ← GetConcreteType[v.type];
WITH ct
SELECT
FROM
sct: ScalarTypePtr =>
SELECT sct
FROM
integer =>
--check for constants
WITH v.value
SELECT
FROM
scv:
REF scalarConstant ValueTail =>
IF scv.v.value >= -32*
K
AND scv.v.value < 64*
K
THEN {a.p ← short; a.lower ← a.upper ← scv.v.value} ELSE a.p ← long;
ENDCASE => a.p ← long;
ENDCASE => a.p ← other; -- real, string, char, boolean, and enumerated types come here
srct: SubRangeTypePtr =>
SELECT GetConcreteType[srct.hostType]
FROM
integer =>
-- all subranges of INT are short in current Cedar
{a.p ← short; a.lower ← srct.lower; a.upper ← srct.upper};
ENDCASE => a.p ← other;
ENDCASE => a.p ← other;
RETURN[a];
END; -- of GetArithLen
LegalShort:
PROCEDURE [u, l:
INT]
RETURNS [
BOOL] =
BEGIN
IF l > u THEN ERROR; -- contradiction!
IF l <= -32*K THEN RETURN[FALSE]; -- Cedar can't handle -32768 as a literal ...
IF u >= 64*K THEN RETURN[FALSE];
IF l < 0 AND u >= 32*K THEN RETURN[FALSE];
RETURN[TRUE];
END; -- of LegalShort
NewSubRangeType:
PROCEDURE [u, l:
INT]
RETURNS [SubRangeTypePtr] =
BEGIN
newType:
REF subRange Type ←
Z.
NEW[subRange Type ←
[subRange[hostType: integer, lower: l, upper: u]]];
RETURN[newType];
END; -- of NewSubRangeType
UpdateTypeIfSubRange:
PROCEDURE [v: ValuePtr, u, l:
INT] =
BEGIN
ct: TypePtr ← GetConcreteType[v.type];
WITH ct
SELECT
FROM
srct: SubRangeTypePtr =>
SELECT GetConcreteType[srct.hostType]
FROM
integer =>
-- all subranges of INT are short in current Cedar
{newType:
REF subRange Type ←
Z.
NEW[subRange Type ←
[subRange[hostType: srct.hostType, lower: l, upper: u]]];
v.type ← newType};
ENDCASE => NULL;
ENDCASE => NULL;
END; -- of UpdateTypeIfSubRange
TranslateExpression:
PUBLIC
PROCEDURE [st: GeneralTypePtr ← nilGeneralTypePtr]
RETURNS [ValuePtr] =
BEGIN v: ValuePtr ← ParseExpression[st]; SayTranslation[v, st]; RETURN[v]; END;
of TranslateExpression
ParseExpression:
PUBLIC
PROCEDURE [st: GeneralTypePtr ← nilGeneralTypePtr]
RETURNS [ValuePtr] =
BEGIN
v1, v2: ValuePtr;
lastOp: Operator;
v1 ← ParseSimpleExpression[st];
IF sy # relOpSy THEN RETURN[v1];
lastOp ← op;
InSymbol[];
v2 ← ParseSimpleExpression[
IF lastOp = inOp THEN PowerSetOf[v1.type] ELSE v1.type];
RETURN[TranslateBinOp[lastOp, st, v1, v2]];
END; -- of ParseExpression
ParseSimpleExpression:
PROCEDURE [st: GeneralTypePtr]
RETURNS [ValuePtr] =
BEGIN
v1, v2: ValuePtr;
lastOp: Operator ← noOp;
IF sy = addOpSy THEN {lastOp ← op; InSymbol[]};
v1 ← ParseTerm[st];
IF lastOp # noOp THEN v1 ← TranslateUnOp[lastOp, v1];
WHILE sy = addOpSy
DO
lastOp ← op;
InSymbol[];
v2 ← ParseTerm[st];
v1 ← TranslateBinOp[lastOp, st, v1, v2];
ENDLOOP;
RETURN[v1];
END; -- of ParseSimpleExpression
ParseTerm:
PROCEDURE [st: GeneralTypePtr]
RETURNS [ValuePtr] =
BEGIN
v1, v2: ValuePtr;
lastOp: Operator;
v1 ← ParseFactor[st];
WHILE sy = mulOpSy
DO
lastOp ← op;
InSymbol[];
v2 ← ParseFactor[st];
v1 ← TranslateBinOp[lastOp, st, v1, v2];
ENDLOOP;
RETURN[v1];
END; -- of ParseTerm
ParseFactor:
PROCEDURE [st: GeneralTypePtr]
RETURNS [ValuePtr] =
BEGIN
v: ValuePtr;
SELECT sy
FROM
lBrackSy => RETURN[ParseSetConstructor[st]];
notSy =>
BEGIN
InSymbol[];
v ← ParseFactor[boolean];
RETURN[TranslateUnOp[notOp, v]];
END;
lParentSy =>
BEGIN
PushOut[];
RespondCh['(];
v ← ParseExpression[st];
SayTranslation[v];
MustBe[rParentSy, ")", MalformedFactor];
RETURN[
Z.
NEW[Value←[type: v.type, value:
Z.
NEW[ValueTail←
[nonConstant[translation: CopyAndPopOut[]]]]]]];
END;
identSy =>
BEGIN
id: IdentifierPtr ← IdentLookup[];
WITH id.class
SELECT
FROM
cidt: ConstantIdentifierTailPtr =>
BEGIN
PushOut[];
SayIdent[ident];
InSymbol[];
RETURN[
Z.
NEW[Value←
[type: id.type,
value: Z.NEW[ValueTail←[scalarConstant[
v: [value: cidt.value, translation: CopyAndPopOut[]]]]]]]];
END;
ridt:
REF realConstant IdentifierTail =>
BEGIN
PushOut[];
SayIdent[ident];
InSymbol[];
RETURN[
Z.
NEW[Value←
[type: id.type,
value: Z.NEW[ValueTail←[otherConstant[translation: CopyAndPopOut[]]]]]]];
END;
caidt:
REF charArrayConstant IdentifierTail =>
BEGIN
PushOut[];
SayIdent[ident];
InSymbol[];
RETURN[
Z.
NEW[Value←
[type: id.type,
value: Z.NEW[ValueTail←[otherConstant[translation: CopyAndPopOut[]]]]]]];
END;
vidt: REF variable IdentifierTail => RETURN[ParseVariable[]];
pid:
REF procedure IdentifierTail =>
BEGIN
v: ValuePtr;
PushOut[];
v ← TranslateProcedureCall[id];
RETURN[
Z.
NEW[Value←
[type: v.type,
value: Z.NEW[ValueTail←[nonConstant[translation: CopyAndPopOut[]]]]]]];
END;
ENDCASE => Error[MalformedFactor];
END;
ENDCASE => NULL; -- I put the RETURN[ParseConstant[]] here,
but the compiler complained of a default return
RETURN[ParseConstant[]];
END; -- of ParseFactor
ParseSetConstructor:
PROCEDURE [st: GeneralTypePtr]
RETURNS [ValuePtr] =
BEGIN
vTail: REF setConstructor ValueTail ← Z.NEW[setConstructor ValueTail←[setConstructor[v: NIL]]];
v: REF Value ← Z.NEW[Value ←[value: vTail]];
tail: SetIntervalPtr ← NIL;
ParseSetInterval:
PROCEDURE =
BEGIN
s: SetIntervalPtr;
vLower: ValuePtr ← ParseExpression[];
IF CouldBe[colonSy, ""]
THEN
s ←
Z.
NEW[interval SetInterval ←[next:
NIL, lower: vLower,
rest: interval[upper: ParseExpression[]]]]
ELSE s ← Z.NEW[singleton SetInterval ← [next: NIL, lower: vLower, rest: singleton[]]];
IF tail = NIL THEN vTail.v ← s ELSE tail.next ← s;
tail ← s;
END; -- of ParseSetInterval;
GuessSetType:
PROCEDURE [st: GeneralTypePtr, int: SetIntervalPtr]
RETURNS [GeneralTypePtr] =
BEGIN
ct: TypePtr ← GetConcreteType[st];
IF ct #
NIL
THEN
WITH ct
SELECT
FROM
pct: PowerTypePtr => RETURN[st]; ENDCASE => NULL;
RETURN[nilGeneralTypePtr]; -- can't decide yet
END; -- of GuessSetType
MustBe[lBrackSy, "", MalformedSetConstructor];
IF
NOT CouldBe[rBrackSy, ""]
THEN
BEGIN
SequenceOf[ParseSetInterval, commaSy, ""];
MustBe[rBrackSy, "", MalformedSetConstructor];
END;
v.type ← GuessSetType[st, vTail.v];
RETURN[v];
END; -- of ParseSetConstructor
ParseConstantExpression:
PUBLIC
PROCEDURE
RETURNS [ValuePtr] =
BEGIN
v: ValuePtr ← ParseExpression[];
IF GetConcreteType[v.type] = string
THEN
WITH v.value
SELECT
FROM
sv:
REF stringConstant ValueTail =>
IF sv.v.Length[] = 1 THEN v.type ← char
ELSE {it: SubRangeTypePtr ←
Z.
NEW[subRange Type ←
[subRange[hostType: integer, lower: 1, upper: sv.v.Length[]]]];
at: ArrayTypePtr ←
Z.
NEW[array Type ←
[array[aIsPacked: TRUE, aElType: char, aIxType: it]]];
v.type ← at};
ENDCASE => NULL;
RETURN[v]
END; -- of ParseConstantExpression
ParseConstant:
PUBLIC
PROCEDURE
RETURNS [ValuePtr] =
BEGIN
prefix: {none, plus, minus} ← none;
PushOut[]; -- for translation of constant
DO
SELECT sy
FROM
identSy =>
-- should be a constant of a scalar type or NIL
BEGIN
id: IdentifierPtr ← IdentLookup[];
SayIdent[ident];
InSymbol[];
WITH id.class
SELECT
FROM
rid:
REF realConstant IdentifierTail =>
RETURN[
Z.
NEW[Value←
[type: id.type,
value: Z.NEW[ValueTail←[otherConstant[translation: CopyAndPopOut[]]]]]]];
cid:
REF constant IdentifierTail =>
RETURN[
Z.
NEW[Value←
[type: id.type,
value: Z.NEW[ValueTail←[scalarConstant[
v:
[value:
IF prefix = minus
THEN -cid.value
ELSE cid.value,
translation: CopyAndPopOut[]]]]]]]];
ENDCASE => Error[MalformedConstant];
END;
addOpSy =>
BEGIN
IF prefix # none THEN Error[MalformedConstant];
prefix ← IF op = minusOp THEN minus ELSE plus;
IF op # plusOp THEN SayCh[SELECT op FROM minusOp => '-, ENDCASE => '?];
InSymbol[];
END;
stringConstSy =>
BEGIN
s: ROPE;
IF prefix # none THEN Error[MalformedConstant];
s ← ident;
PopOut[]; -- this constant has no translation yet
InSymbol[];
RETURN[Z.NEW[Value←[type: string, value: Z.NEW[ValueTail←[stringConstant[v: s]]]]]];
END;
intConstSy =>
BEGIN
i: PascalInteger ← StringToPascalInteger[ident];
IF prefix = minus THEN i ← -i;
Say[ident];
InSymbol;
RETURN[
Z.
NEW[Value←
[type: integerId,
value: Z.NEW[ValueTail←[scalarConstant[
v: [value: i, translation: CopyAndPopOut[]]]]]]]];
END;
realConstSy =>
BEGIN
Say[ident];
InSymbol;
RETURN[
Z.
NEW[Value←
[type: realId,
value: Z.NEW[ValueTail←[otherConstant[translation: CopyAndPopOut[]]]]]]];
END;
ENDCASE => Error[MalformedConstant];
ENDLOOP;
END; -- of ParseConstant
ParseCountableConstant:
PUBLIC
PROCEDURE
RETURNS [ScalarConstantValuePtr] =
BEGIN
v: ValuePtr ← ParseConstant[];
DO
WITH v.value
SELECT
FROM
scv:
REF scalarConstant ValueTail =>
BEGIN
t: TypePtr ← GetConcreteTypeOfValue[v];
WITH t
SELECT
FROM
srt: SubRangeTypePtr => RETURN[v];
st: ScalarTypePtr => IF t # real AND t # string THEN RETURN[v];
ENDCASE => NULL;
EXIT;
END;
stv: REF stringConstant ValueTail => ExpressStringConstant[v, char];
ENDCASE => EXIT;
ENDLOOP;
Error[MalformedConstant];
RETURN[NIL]; -- never gets here
END; -- of ParseCountableConstant
ParseFiniteConstant:
PUBLIC
PROCEDURE
RETURNS [ScalarConstantValuePtr] =
BEGIN
scv: ScalarConstantValuePtr ← ParseCountableConstant[];
t: TypePtr ← GetConcreteTypeOfValue[scv];
IF t # integer THEN RETURN[scv] ELSE Error[MalformedConstant];
RETURN[NIL]; -- never gets here
END; -- of ParseFiniteConstant
TranslateUnOp:
PROCEDURE [op: Operator, vp1: ValuePtr]
RETURNS [v: ValuePtr] =
BEGIN
v ← Z.NEW[Value];
v^ ← vp1^;
PushOut[];
SELECT op
FROM
plusOp => NULL;
minusOp =>
BEGIN
a: ArithLen ← GetArithLen[v];
SayCh['-];
WITH v.value
SELECT
FROM
scv: REF scalarConstant ValueTail => scv.v.value ← -scv.v.value;
ENDCASE;
IF a.p = short
THEN
IF NOT LegalShort[l: -a.upper, u: -a.lower] THEN CoerceToLong[v]
ELSE UpdateTypeIfSubRange[v: v, l: -a.upper, u: -a.lower];
END;
notOp =>
BEGIN
Say["NOT "];
WITH v.value
SELECT
FROM
scv: REF scalarConstant ValueTail => scv.v.value ← 1 - scv.v.value;
ENDCASE;
END;
ENDCASE;
SayTranslation[v];
WITH v.value
SELECT
FROM
vv:
REF variable ValueTail =>
v.value←
Z.
NEW[nonConstant ValueTail←
[nonConstant[translation: CopyAndPopOut[]]]];
ncv: REF nonConstant ValueTail => ncv.translation ← CopyAndPopOut[];
ocv: REF otherConstant ValueTail => ocv.translation ← CopyAndPopOut[];
scv: REF scalarConstant ValueTail => scv.v.translation ← CopyAndPopOut[];
ENDCASE => Error[IllegalValue];
END; -- of TranslateUnOp
TranslateBinOp:
PROCEDURE [op: Operator, rt: GeneralTypePtr, vp1, vp2: ValuePtr]
RETURNS [v: ValuePtr] =
BEGIN
OperandType:
TYPE = {
boolean, integer, otherScalar, real, string, pointer, record, set};
isString1, isString2: BOOLEAN;
vTypeSet: BOOLEAN;
string1Length, string2Length: PascalInteger;
GetOperandType:
PROCEDURE
RETURNS [OperandType] =
BEGIN
t1: TypePtr ← GetConcreteType[vp1.type];
t2: TypePtr ← GetConcreteType[vp2.type];
[isString1, string1Length] ← CheckForPascalString[vp1.type];
[isString2, string2Length] ← CheckForPascalString[vp2.type];
RETURN[
SELECT
TRUE
FROM
vp1.value.binding = setConstructor
OR (t1 #
NIL
AND t1.form = power) =>
FixupSetTypes[rt, vp1, vp2],
(t1.form = scalar OR t1.form = subRange) AND (vp2.value.binding = setConstructor OR (t2 # NIL AND t2.form = power)) => otherScalar, -- for the IN operator.
t1.form = pointer => pointer,
t1.form = record => record,
isString2 => FixupStringTypes[vp1, vp2, FALSE],
isString1 => FixupStringTypes[vp1, vp2, TRUE],
ENDCASE => FixupScalarTypes[vp1, vp2]];
END; -- of GetOperandType
FixupStringTypes:
PROCEDURE [vp1, vp2: ValuePtr, reverse:
BOOLEAN]
RETURNS [OperandType] =
BEGIN -- at least second operand is a string
InternalStringFixup:
PROCEDURE [vp1, vp2: ValuePtr]
RETURNS [OperandType] =
BEGIN
WITH vp2.value
SELECT
FROM
dv2:
REF stringConstant ValueTail =>
BEGIN
IF GetConcreteTypeOfValue[vp1] = char
AND dv2.v.Length[] = 1
THEN
a CHAR
BEGIN ExpressStringConstant[vp2, vp1.type]; RETURN[otherScalar]; END
ELSE ExpressStringConstant[vp2, string];
not a CHAR
END;
ENDCASE =>
-- v2 is not a string constant
WITH vp1.value
SELECT
FROM
dv1:
REF stringConstant ValueTail =>
ExpressStringConstant[vp1, string];
ENDCASE => NULL;
RETURN[string];
END; -- of InternalStringFixup;
ot: OperandType ←
IF reverse THEN InternalStringFixup[vp2, vp1]
ELSE InternalStringFixup[vp1, vp2];
[isString1, string1Length] ← CheckForPascalString[vp1.type];
[isString2, string2Length] ← CheckForPascalString[vp2.type];
RETURN[ot];
END; -- of FixupStringTypes
FixupScalarTypes:
PROCEDURE [vp1, vp2: ValuePtr]
RETURNS [OperandType] =
BEGIN
t1: TypePtr ← GetScalarType[vp1.type];
t2: TypePtr ← GetScalarType[vp2.type];
a1: ArithLen ← GetArithLen[vp1];
a2: ArithLen ← GetArithLen[vp2];
SELECT
TRUE
FROM
t1 = integer
AND t2 = integer
AND op = rDivOp =>
BEGIN CoerceToReal[vp1]; CoerceToReal[vp2]; RETURN[real]; END;
op = iDivOp =>
BEGIN
IF t1 = real THEN CoerceToInteger[vp1];
IF t2 = real THEN CoerceToInteger[vp2];
RETURN[integer];
END;
t1 = integer
AND t2 = integer
AND a1.p = short
AND a2.p = short =>
{
-- we have to worry here about short versus long arithmetic
ProcessArith:
PROC [l, u:
INT] =
-- args are known bounds on result value
{minL:
INT ←
MIN[l, a1.lower, a2.lower];
maxU: INT ← MAX[u, a1.upper, a2.upper];
IF NOT LegalShort[l: minL, u: maxU] THEN CoerceToLong[vp1]
ELSE {v.type ← NewSubRangeType[l:l, u:u]; vTypeSet← TRUE}
};
SELECT op
FROM
IN [ltOp..geOp] => CoerceToLong[vp1];
= plusOp => ProcessArith[l: a1.lower + a2.lower, u: a1.upper + a2.upper];
= minusOp =>ProcessArith[l: a1.lower - a2.upper, u: a1.upper - a2.lower];
= mulOp => {resL:
INT ←
MIN[a1.lower * a2.lower, a1.lower * a2.upper,
a1.upper * a2.lower, a1.upper * a2.upper];
resU:
INT ←
MAX[a1.lower * a2.lower, a1.lower * a2.upper,
a1.upper * a2.lower, a1.upper * a2.upper];
IF a1.upper > 32*
K
AND a2.upper > 32*
K
THEN CoerceToLong[vp1]
special case because of possible overflow in the long multiplies
ELSE ProcessArith[l: resL, u: resU]};
ENDCASE => NULL;
RETURN[integer]};
t1 = integer AND t2 = integer => RETURN[integer];
t1 = real AND t2 = real => RETURN[real];
t1 = integer AND t2 = real => {CoerceToReal[vp1]; RETURN[real]};
t1 = real AND t2 = integer => {CoerceToReal[vp2]; RETURN[real]};
t1 = boolean AND t2 = boolean => RETURN[boolean];
t1 = t2 OR op = inOp => RETURN[otherScalar];
ENDCASE => Error[IncompatibleOperands];
RETURN[otherScalar]; -- never gets here
END; -- of FixupScalarTypes
FixupSetTypes:
PROCEDURE [tr: GeneralTypePtr, vp1, vp2: ValuePtr]
RETURNS [OperandType] =
BEGIN
InheritSetType[tr, vp1];
InheritSetType[vp2.type, vp1];
InheritSetType[vp1.type, vp2];
RETURN[set];
END; -- of FixupSetTypes
InheritSetType:
PROCEDURE [it: GeneralTypePtr, vp: ValuePtr] =
BEGIN
cit: TypePtr ← GetConcreteType[it];
cvt: TypePtr ← GetConcreteType[vp.type];
IF cit # NIL AND (cvt = NIL OR IsSubSet[cit, cvt]) THEN vp.type ← it;
END; -- of InheritSetType
IsSubSet:
PROCEDURE [t1, t2: TypePtr]
RETURNS [
BOOLEAN] =
BEGIN
bt1: GeneralTypePtr ← GetPowerBaseType[t1];
bt2: GeneralTypePtr ← GetPowerBaseType[t2];
IF bt1 # nilGeneralTypePtr
AND bt2 # nilGeneralTypePtr
AND
GetCountableHostType[bt1] = GetCountableHostType[bt2] THEN
BEGIN
ct1: TypePtr ← GetConcreteType[bt1];
WITH ct1
SELECT
FROM
srCt1: SubRangeTypePtr =>
BEGIN
ct2: TypePtr ← GetConcreteType[bt2];
WITH ct2
SELECT
FROM
sCt2: ScalarTypePtr => RETURN[TRUE];
srCt2: SubRangeTypePtr =>
BEGIN
l1, l2, u1, u2: PascalInteger;
[lower: l1, upper: u1] ← GetFiniteType[bt1];
[lower: l2, upper: u2] ← GetFiniteType[bt2];
RETURN[l2 <= l1 AND u1 <= u2];
END;
ENDCASE => NULL;
END;
ENDCASE => NULL;
END;
RETURN[FALSE];
END; -- of IsSubSet
BinaryInfix:
PROCEDURE [s:
ROPE, t: GeneralTypePtr] =
BEGIN
IF NOT vTypeSet THEN {v.type ← t; vTypeSet ← TRUE};
PushOut[];
SayTranslation[vp1];
Say[s];
SayTranslation[vp2];
WITH v.value
SELECT
FROM
dv: REF variable ValueTail => dv.translation ← CopyAndPopOut[];
dv: REF nonConstant ValueTail => dv.translation ← CopyAndPopOut[];
dv: REF scalarConstant ValueTail => dv.v.translation ← CopyAndPopOut[];
ENDCASE => Error[IllegalValue];
END; -- of BinaryInfix
BinaryPrefix:
PROCEDURE [s:
ROPE, t: GeneralTypePtr] =
BEGIN
IF NOT vTypeSet THEN {v.type ← t; vTypeSet ← TRUE};
PushOut[];
Say[s];
SayCh['[];
SayTranslation[vp1];
SayCh[',];
SayTranslation[vp2];
SayCh[']];
WITH v.value
SELECT
FROM
dv: REF variable ValueTail => dv.translation ← CopyAndPopOut[];
dv: REF nonConstant ValueTail => dv.translation ← CopyAndPopOut[];
dv: REF scalarConstant ValueTail => dv.v.translation ← CopyAndPopOut[];
ENDCASE => Error[IllegalValue];
END; -- of BinaryPrefix
TryConstant:
PROCEDURE[]
RETURNS [ValuePtr] =
BEGIN
WITH vp1.value
SELECT
FROM
cv1:
REF scalarConstant ValueTail =>
WITH vp2.value
SELECT
FROM
cv2:
REF scalarConstant ValueTail =>
BEGIN
a: PascalInteger ← cv1.v.value;
b: PascalInteger ← cv2.v.value;
c: PascalInteger;
SELECT op
FROM
plusOp => c ← a + b;
minusOp => c ← a - b;
mulOp => c ← a * b;
iDivOp => c ← a/b;
modOp => c ← a MOD b;
andOp => c ← IF (a # 0) AND (b # 0) THEN 1 ELSE 0;
orOp => c ← IF (a # 0) OR (b # 0) THEN 1 ELSE 0;
ltOp => c ← IF a < b THEN 1 ELSE 0;
gtOp => c ← IF a > b THEN 1 ELSE 0;
leOp => c ← IF a <= b THEN 1 ELSE 0;
geOp => c ← IF a >= b THEN 1 ELSE 0;
neOp => c ← IF a # b THEN 1 ELSE 0;
eqOp => c ← IF a = b THEN 1 ELSE 0;
ENDCASE => RETURN[Z.NEW[Value←[value: Z.NEW[ValueTail←[nonConstant[]]]]]];
RETURN[
Z.
NEW[Value←[value:
Z.
NEW[ValueTail←[scalarConstant[v:
[value: c]]]]]]];
END;
ENDCASE => RETURN[Z.NEW[Value←[value: Z.NEW[ValueTail←[nonConstant[]]]]]];
ENDCASE => RETURN[Z.NEW[Value←[value: Z.NEW[ValueTail←[nonConstant[]]]]]];
END; -- of TryConstantOp
t: OperandType;
v ← TryConstant[];
vTypeSet ← FALSE;
t ← GetOperandType[];
SELECT TRUE FROM
t
IN [integer..real]
AND op
IN [plusOp..rDivOp] =>
BinaryInfix[
(
SELECT op
FROM
plusOp => "+",
minusOp => "-",
mulOp => "*",
rDivOp => "/",
ENDCASE => "?"),
IF GetConcreteType[vp2.type] = integer
THEN integer ELSE vp1.type];
t = integer
AND op
IN [iDivOp..modOp] =>
BEGIN
byPower2: BOOL ← FALSE;
mask: INT ← 0;
power: INT ← 0;
WITH vp2.value
SELECT
FROM
cv2:
REF scalarConstant ValueTail =>
BEGIN
IF cv2.v.value > 0
THEN {
m: LONG CARDINAL ← cv2.v.value;
WHILE m
MOD 2 = 0
DO
m ← m/2;
power ← power + 1;
ENDLOOP;
IF m = 1 THEN {byPower2 ← TRUE; mask ← cv2.v.value-1};
};
END;
ENDCASE => NULL;
IF byPower2
THEN
BEGIN
PushOut[];
Say["Pascal"];
Say[SELECT op FROM iDivOp => "DIVPower2", modOp => "MODPower2Mask", ENDCASE => "?"];
SayCh['[];
SayTranslation[vp1];
SayCh[',];
SayPascalInteger[
SELECT op FROM iDivOp => power, modOp => mask, ENDCASE => 0
];
SayCh[']];
v^ ← [type: integer, value: Z.NEW[ValueTail←[nonConstant[translation: CopyAndPopOut[]]]]];
END
ELSE BinaryInfix[
(SELECT op FROM iDivOp => "/", modOp => "MOD ", ENDCASE => "?"),
vp1.type];
END;
t = boolean
AND op
IN [andOp..orOp] =>
BinaryInfix[
(SELECT op FROM andOp => "AND ", orOp => "OR ", ENDCASE => "?"),
vp1.type];
t
IN [boolean..real]
AND op
IN [ltOp..eqOp] =>
BinaryInfix[
(
SELECT op
FROM
ltOp => "<",
gtOp => ">",
leOp => "<=",
geOp => ">=",
neOp => "#",
eqOp => "=",
ENDCASE => "?"), boolean];
t
IN [pointer..record]
AND op
IN [neOp..eqOp] =>
BinaryInfix[
(SELECT op FROM neOp => "#", eqOp => "=", ENDCASE => "?"),
boolean];
t = string
AND op
IN [ltOp..eqOp] =>
BEGIN
PushOut[];
SayCh['(];
Say["Pascal"];
IF targetLanguage = longMesa OR targetLanguage = cedar THEN Say["Long"];
Say["StringCompare["];
IF string1Length # -1 THEN SayCh['@];
SayTranslation[vp1];
SayCh[',];
SayPascalInteger[string1Length];
Say[", "];
IF string2Length # -1 THEN SayCh['@];
SayTranslation[vp2];
SayCh[',];
SayPascalInteger[string2Length];
SayCh[']];
Say[
SELECT op
FROM
ltOp => "<",
gtOp => ">",
leOp => "<=",
geOp => ">=",
neOp => "#",
eqOp => "=",
ENDCASE => "?"];
Say["0)"];
v^ ← [type: boolean, value: Z.NEW[ValueTail←[nonConstant[translation: CopyAndPopOut[]]]]];
END;
t = set
AND op
IN [plusOp..mulOp], t = set
AND op
IN [leOp..eqOp] =>
BEGIN
rt: GeneralTypePtr ←
IF op IN [leOp..eqOp] THEN boolean ELSE vp1.type;
BinaryPrefix[
(
SELECT op
FROM
plusOp => "Union",
minusOp => "Difference",
mulOp => "Intersection",
leOp => "IsSubset",
geOp => "IsSuperset",
neOp => "IsDifferent",
eqOp => "IsSame",
ENDCASE => "?"), rt];
PushOut[];
SaySetType[GetConcreteType[vp1.type]];
SayTranslation[v];
v^ ← [type: rt, value: Z.NEW[ValueTail←[nonConstant[translation: CopyAndPopOut[]]]]];
END;
t
IN [boolean..otherScalar]
AND op = inOp =>
BEGIN
PushOut[];
WITH vp2.value
SELECT
FROM
dv:
REF setConstructor ValueTail =>
IF dv.v = NIL THEN Say["FALSE "]
ELSE
BEGIN
Say["(SELECT "];
SayTranslation[vp1];
Say[" FROM "];
SaySetConstructorAsList[GetPowerBaseType[vp2.type], dv.v];
Say[" => TRUE, ENDCASE => FALSE)"];
END;
ENDCASE =>
BEGIN
SayTranslation[vp2];
SayCh['[];
SayTranslationOfSetIndex[GetPowerBaseType[vp2.type], vp1];
SayCh[']];
END;
v^ ← [type: boolean, value: Z.NEW[ValueTail←[nonConstant[translation: CopyAndPopOut[]]]]];
END;
ENDCASE => Error[IllegalOperation];
RETURN;
END; -- of TranslateBinOp
GetPowerBaseType:
PROCEDURE [t: GeneralTypePtr]
RETURNS [GeneralTypePtr] =
BEGIN
ct: TypePtr ← GetConcreteType[t];
WITH ct SELECT FROM dt: PowerTypePtr => RETURN[dt.baseType]; ENDCASE => NULL;
RETURN[nilGeneralTypePtr];
END; -- of GetPowerBaseType
CoerceToReal:
PUBLIC
PROCEDURE [vp: ValuePtr]=
BEGIN -- from INTEGER
PushOut[];
Say["PascalFLOAT["];
SayTranslation[vp];
SayCh[']];
vp^ ← [type: real, value: Z.NEW[ValueTail←[nonConstant[translation: CopyAndPopOut[]]]]];
END; -- of CoerceToReal
CoerceToInteger:
PROCEDURE [vp: ValuePtr]=
BEGIN -- from REAL
PushOut[];
Say["PascalROUND["];
SayTranslation[vp];
SayCh[']];
vp^ ← [type: integer, value: Z.NEW[ValueTail←[nonConstant[translation: CopyAndPopOut[]]]]];
END; -- of CoerceToInteger
CoerceToLong:
PUBLIC
PROCEDURE [vp: ValuePtr]=
BEGIN -- from short, of course
IF targetLanguage # cedar THEN RETURN; -- no longs to worry about
PushOut[];
Say[" INT["];
SayTranslation[vp];
SayCh[']];
vp^ ← [type: integer, value: Z.NEW[ValueTail←[nonConstant[translation: CopyAndPopOut[]]]]];
END; -- of CoerceToLong
ExpressStringConstant:
PUBLIC
PROCEDURE [v: ValuePtr, st: GeneralTypePtr] =
BEGIN
WITH v.value
SELECT
FROM
scv:
REF stringConstant ValueTail =>
BEGIN
isPascalString: BOOLEAN;
pascalStringLength: PascalInteger;
IF st = nilGeneralTypePtr
THEN
st ← IF scv.v.Length[] = 1 THEN char ELSE string;
[is: isPascalString, length: pascalStringLength] ← CheckForPascalString[
t: st];
PushOut[];
SELECT
TRUE
FROM
GetConcreteType[st] = string =>
BEGIN
i: CARDINAL;
SayCh['"];
FOR i
IN [0..
NAT[scv.v.Length[]])
DO
thisCh: CHAR ← scv.v.Fetch[i];
IF thisCh = '\\ OR thisCh = '" THEN SayCh['\\];
Say[""""];
END;
isPascalString =>
BEGIN
i: CARDINAL;
WITH st
SELECT
FROM
likeSt: REF Identifier => SayIdent[likeSt.name]; -- explicit type
ENDCASE => NULL; -- implicit type
SayCh['[];
FOR i
IN
[0..MAX[NAT[scv.v.Length[]], NarrowPascalInteger[pascalStringLength]]) DO
thisChar: CHAR;
IF i # 0 THEN Say[", "];
SayCh[''];
thisChar ← IF i < scv.v.Length[] THEN scv.v.Fetch[i] ELSE ' ;
SayCharCh[thisChar];
IF thisChar = '\\ THEN SayCh['\\];
ENDLOOP;
SayCh[']];
v^ ← [type: st,
value: Z.NEW[ValueTail ←[otherConstant[translation: CopyAndPopOut[]]]]];
RETURN;
END;
IsCountableHostType[st]
AND GetCountableHostType[st] = char =>
BEGIN
c: CHARACTER;
IF scv.v.Length[] # 1 THEN Error[CantExpressString];
c ← scv.v.Fetch[0];
SayCh[''];
SayCharCh[c];
IF c='\\ THEN SayCh[c]; -- must say c again if c is the escape char
v^ ← [type: st,
value: Z.NEW[ValueTail ←[scalarConstant[
v: [value: LOOPHOLE[c, CARDINAL], translation: CopyAndPopOut[]]]]]];
RETURN;
END;
ENDCASE => Error[CantExpressString];
v^ ← [type: st, value: Z.NEW[ValueTail←[nonConstant[translation: CopyAndPopOut[]]]]];
END;
ENDCASE => NULL; -- not a string constant
END;
SayStringCh:
PROCEDURE [c:
CHARACTER] = {
SayCh[IF capitalizeStrings AND c IN ['a..'z] THEN c + ('A - 'a) ELSE c]};
SayCharCh:
PROCEDURE [c:
CHARACTER] = {
SayCh[IF capitalizeChars AND c IN ['a..'z] THEN c + ('A - 'a) ELSE c]};
ExtractTranslation:
PUBLIC
PROCEDURE [
v: ValuePtr, st: GeneralTypePtr ← nilGeneralTypePtr]
RETURNS [q: OutputQueuePtr] =
BEGIN
WITH v.value
SELECT
FROM
dv:
REF variable ValueTail =>
{q ← dv.translation; dv.translation ← NIL};
dv:
REF nonConstant ValueTail =>
{q ← dv.translation; dv.translation ← NIL};
dv:
REF otherConstant ValueTail =>
{q ← dv.translation; dv.translation ← NIL};
sv:
REF scalarConstant ValueTail =>
{q ← sv.v.translation; sv.v.translation ← NIL};
scv:
REF stringConstant ValueTail =>
BEGIN
ExpressStringConstant[v, st];
RETURN[ExtractTranslation[v, st]];
END;
scv:
REF setConstructor ValueTail =>
BEGIN
PushOut[];
SaySetConstructor[v.type, scv.v];
q ← CopyAndPopOut[]
END;
ENDCASE;
END; -- of ExtractTranslation
SaySetConstructor:
PROCEDURE [t: GeneralTypePtr, ip: SetIntervalPtr] =
BEGIN -- t cannot be NIL
baseType: GeneralTypePtr ← GetPowerBaseType[t];
SaySetType[GetConcreteType[t]];
IF ip = NIL THEN {Say["Empty"]; RETURN};
Say[IF ip.next = NIL THEN "Generate" ELSE "Add"];
WITH ip
SELECT
FROM
sip:
REF singleton SetInterval =>
BEGIN Say["Element["]; SayTranslationOfSetIndex[baseType, sip.lower]; END;
iip:
REF interval SetInterval =>
BEGIN
Say["Interval["];
SayTranslationOfSetIndex[baseType, iip.lower];
Say[", "];
SayTranslationOfSetIndex[baseType, iip.upper];
END;
ENDCASE;
IF ip.next # NIL THEN {Say[", "]; SaySetConstructor[t, ip.next]};
SayCh[']];
END; -- of SaySetConstructor
SaySetConstructorAsList:
PROCEDURE [
baseType: GeneralTypePtr, ip: SetIntervalPtr] =
BEGIN -- guaranteed not NIL
hostType: GeneralTypePtr ← GetCountableHostType[baseType];
WITH ip
SELECT
FROM
sip: REF singleton SetInterval => SayTranslation[sip.lower, hostType];
iip:
REF interval SetInterval =>
BEGIN
Say[" IN["];
SayTranslation[iip.lower, hostType];
Say[".."];
SayTranslation[iip.upper, hostType];
SayCh[']];
END;
ENDCASE;
IF ip.next # NIL THEN {Say[", "]; SaySetConstructorAsList[baseType, ip.next]};
END; -- of SaySetConstructor
SayTranslationOfSetIndex:
PROCEDURE [baseType: GeneralTypePtr, v: ValuePtr] =
BEGIN
q1, q2: OutputQueuePtr;
hostType: GeneralTypePtr ← GenCountableHostType[baseType];
PushOut[];
SELECT GetConcreteType[hostType]
FROM
integer => SayTranslation[v];
ENDCASE =>
BEGIN
Say["PascalORD["];
SayType[hostType];
SayCh['[];
SayTranslation[v, hostType];
Say["]]"]
END;
q1 ← CopyAndPopOut[];
PushOut[];
SaySetOriginOffset[baseType];
q2 ← CopyAndPopOut[];
IF q2.contents.Length[] = 0 THEN MergeQueue[from: q1]
ELSE
BEGIN
SayCh['(];
MergeQueue[from: q1];
SayCh[')];
MergeQueue[from: q2];
END;
END; -- of SayTranslationOfSetIndex
SayTranslation:
PUBLIC
PROCEDURE [
v: ValuePtr, st: GeneralTypePtr ← nilGeneralTypePtr] =
BEGIN q: OutputQueuePtr ← ExtractTranslation[v, st]; MergeQueue[from: q]; END;
of SayTranslation
END. -- of PasExpr --