

<<file:  PasExpr.mesa>>
<<modified by Ramshaw, January 20, 1984 4:07 pm>>
<<written by McCreight, November 20, 1980  2:50 PM>>
<<Last Edited by: Nichols, August 8, 1983 3:18 pm>>
<<Last Edited by: Pavel, September 19, 1984 10:54:04 am PDT>>
<<>>
DIRECTORY
PasPrivate,
PasPrivateVars,
Rope USING [Fetch, Length];

PasExpr: CEDAR PROGRAM IMPORTS PasPrivate, PasPrivateVars, Rope EXPORTS PasPrivate =

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['\\];
SayCh[thisCh];
ENDLOOP;
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 --