
<<IPTypeImpl.mesa>>
<<Copyright © 1984 Xerox Corporation.  All rights reserved.>>
<<Doug Wyatt, November 13, 1984 6:01:38 pm PST>>

DIRECTORY
Atom USING [MakeAtomFromRefText],
IO USING [PutFR, int, real, rope, STREAM],
IPInterpreter,
Real USING [Fix, RealException],
RefText USING [AppendRope, ObtainScratch, ReleaseScratch],
Rope USING [ROPE, Size, Substr];

IPTypeImpl: CEDAR PROGRAM
IMPORTS Atom, IO, IPInterpreter, Real, RefText, Rope
EXPORTS IPInterpreter
= BEGIN OPEN IPInterpreter;

ROPE: TYPE ~ Rope.ROPE;
STREAM: TYPE ~ IO.STREAM;

NumberFromInteger: PUBLIC PROC[i: Integer] RETURNS[Number] ~ {
RETURN[NEW[NumberRep _ [int[CheckInteger[i]]]]];
};

NumberFromInt: PUBLIC PROC[i: INT] RETURNS[Number] ~ {
RETURN[NEW[NumberRep _ [int[i]]]];
};

NumberFromReal: PUBLIC PROC[r: REAL] RETURNS[Number] ~ {
RETURN[NEW[NumberRep _ [real[r]]]];
};

zero: Number ~ NumberFromInteger[0];

NonNIL: PROC[x: Any] RETURNS[Any] ~ {
IF x=NIL THEN {
MasterWarning[$nullValue, "Used initial zero value."];
x _ zero;
};
IF x#NIL THEN RETURN[x] ELSE ERROR;
};

IntegerFromInt: PUBLIC PROC[x: INT] RETURNS[Integer] ~ {
IF x IN[0..maxInteger] THEN RETURN[x];
MasterError[$notInteger, IO.PutFR["%g is not an Integer.", IO.int[x]]];
ERROR Error;
};

Fix: PROC[r: REAL] RETURNS[INT] ~ { RETURN[Real.Fix[r]] };
<<Wrap a procedure call around Real.Fix so we can catch RealException>>
<<>>
IntegerFromReal: PUBLIC PROC[x: REAL] RETURNS[Integer] ~ {
i: INT _ 0; ok: BOOL _ TRUE;
i _ Fix[x ! Real.RealException => { ok _ FALSE; CONTINUE }];
IF ok AND i=x AND IsInteger[i] THEN RETURN[i];
MasterError[$notInteger, IO.PutFR["%g is not an Integer.", IO.real[x]]];
ERROR Error;
};

IntFromReal: PUBLIC PROC[x: REAL] RETURNS[INT] ~ {
i: INT _ 0; ok: BOOL _ TRUE;
i _ Fix[x ! Real.RealException => { ok _ FALSE; CONTINUE }];
IF ok AND i=x THEN RETURN[i];
MasterError[$notInteger, IO.PutFR["%g is not an INT.", IO.real[x]]];
ERROR Error;
};

RopeFromTypeArray: TYPE ~ ARRAY TypeCode OF ROPE;
ropeFromType: REF RopeFromTypeArray ~ InitRopeFromType[];

InitRopeFromType: PROC RETURNS[REF RopeFromTypeArray] ~ {
ropeFromType: REF RopeFromTypeArray ~ NEW[RopeFromTypeArray _ ALL[NIL]];
ropeFromType[null] _ "null";
ropeFromType[number] _ "number";
ropeFromType[identifier] _ "identifier";
ropeFromType[vector] _ "vector";
ropeFromType[operator] _ "operator";
ropeFromType[transformation] _ "transformation";
ropeFromType[pixelArray] _ "pixelArray";
ropeFromType[color] _ "color";
ropeFromType[trajectory] _ "trajectory";
ropeFromType[outline] _ "outline";
ropeFromType[other] _ "other";
FOR t: TypeCode IN TypeCode DO
IF ropeFromType[t]=NIL THEN ropeFromType[t] _ IO.PutFR["[%g]", IO.int[ORD[t]]];
ENDLOOP;
RETURN[ropeFromType];
};

WrongType: PROC[x: Any, expected: TypeCode] ~ {
is: TypeCode ~ Type[x];
MasterError[$wrongType, IO.PutFR["Value has wrong type (is %g, expected %g).",
IO.rope[ropeFromType[is]], IO.rope[ropeFromType[expected]]]];
};

IntegerFromAny: PUBLIC PROC[x: Any] RETURNS[Integer] ~ {
WITH x SELECT FROM
x: Number => WITH x: x SELECT FROM
int => RETURN[IntegerFromInt[x.int]];
real => RETURN[IntegerFromReal[x.real]];
ENDCASE;
ENDCASE;
IF x=NIL THEN RETURN[IntegerFromAny[NonNIL[x]]];
WrongType[x, $number]; ERROR Error;
};

IntFromAny: PUBLIC PROC[x: Any] RETURNS[Integer] ~ {
WITH x SELECT FROM
x: Number => WITH x: x SELECT FROM
int => RETURN[x.int];
real => RETURN[IntFromReal[x.real]];
ENDCASE;
ENDCASE;
IF x=NIL THEN RETURN[IntFromAny[NonNIL[x]]];
WrongType[x, $number]; ERROR Error;
};

RealFromAny: PUBLIC PROC[x: Any] RETURNS[REAL] ~ {
WITH x SELECT FROM
x: Number => WITH x: x SELECT FROM
int => RETURN[REAL[x.int]];
real => RETURN[x.real];
ENDCASE;
ENDCASE;
IF x=NIL THEN RETURN[RealFromAny[NonNIL[x]]];
WrongType[x, $number]; ERROR Error;
};

NumberFromAny: PUBLIC PROC[x: Any] RETURNS[Number] ~ {
WITH x SELECT FROM x: Number => RETURN[x]; ENDCASE;
IF x=NIL THEN RETURN[NumberFromAny[NonNIL[x]]];
WrongType[x, $number]; ERROR Error;
};

IdentifierFromAny: PUBLIC PROC[x: Any] RETURNS[Identifier] ~ {
WITH x SELECT FROM x: Identifier => RETURN[x]; ENDCASE;
WrongType[x, $identifier]; ERROR Error;
};

VectorFromAny: PUBLIC PROC[x: Any] RETURNS[Vector] ~ {
WITH x SELECT FROM x: Vector => RETURN[x]; ENDCASE;
WrongType[x, $vector]; ERROR Error;
};

OperatorFromAny: PUBLIC PROC[x: Any] RETURNS[Operator] ~ {
WITH x SELECT FROM x: Operator => RETURN[x]; ENDCASE;
WrongType[x, $operator]; ERROR Error;
};

TransformationFromAny: PUBLIC PROC[x: Any] RETURNS[Transformation] ~ {
WITH x SELECT FROM x: Transformation => RETURN[x]; ENDCASE;
WrongType[x, $transformation]; ERROR Error;
};

PixelArrayFromAny: PUBLIC PROC[x: Any] RETURNS[PixelArray] ~ {
WITH x SELECT FROM x: PixelArray => RETURN[x]; ENDCASE;
WrongType[x, $pixelArray]; ERROR Error;
};

ColorFromAny: PUBLIC PROC[x: Any] RETURNS[Color] ~ {
WITH x SELECT FROM x: Color => RETURN[x]; ENDCASE;
WrongType[x, $color]; ERROR Error;
};

TrajectoryFromAny: PUBLIC PROC[x: Any] RETURNS[Trajectory] ~ {
WITH x SELECT FROM x: Trajectory => RETURN[x]; ENDCASE;
WrongType[x, $trajectory]; ERROR Error;
};

OutlineFromAny: PUBLIC PROC[x: Any] RETURNS[Outline] ~ {
WITH x SELECT FROM x: Outline => RETURN[x]; ENDCASE;
WrongType[x, $outline]; ERROR Error;
};

Eq: PUBLIC PROC[a, b: Any] RETURNS[BOOL] ~ {
WITH a SELECT FROM
a: Number => WITH b SELECT FROM
b: Number => WITH a: a SELECT FROM
int => WITH b: b SELECT FROM
int => RETURN[a.int=b.int];
real => RETURN[a.int=b.real];
ENDCASE;
real => WITH b: b SELECT FROM
int => RETURN[a.real=b.int];
real => RETURN[a.real=b.real];
ENDCASE;
ENDCASE;
ENDCASE;
a: Identifier => WITH b SELECT FROM
b: Identifier => RETURN[a.atom=b.atom];
ENDCASE;
ENDCASE;
IF a=NIL OR b=NIL THEN RETURN[Eq[NonNIL[a], NonNIL[b]]]
ELSE RETURN[FALSE];
};

EqVector: PROC[a, b: Vector] RETURNS[BOOL] ~ {
aShape: VectorShape ~ Shape[a];
bShape: VectorShape ~ Shape[b];
IF aShape.l#bShape.l OR aShape.n#bShape.n THEN RETURN[FALSE];
FOR i: Integer IN[aShape.l..aShape.l+aShape.n) DO
IF NOT Eq[Get[a, i], Get[b, i]] THEN RETURN[FALSE];
ENDLOOP;
RETURN[TRUE];
};

EqName: PUBLIC PROC[a, b: Any] RETURNS[BOOL] ~ {
IF Eq[a, b] THEN RETURN[TRUE];
WITH a SELECT FROM
a: Vector => WITH b SELECT FROM
b: Vector => RETURN[EqVector[a, b]];
ENDCASE;
ENDCASE;
RETURN[FALSE];
};

Type: PUBLIC PROC[a: Any] RETURNS[TypeCode] ~ {
WITH a SELECT FROM
x: Number => RETURN[$number];
x: Identifier => RETURN[$identifier];
x: Vector => RETURN[$vector];
x: Operator => RETURN[$operator];
x: Transformation => RETURN[$transformation];
x: PixelArray => RETURN[$pixelArray];
x: Color => RETURN[$color];
x: Trajectory => RETURN[$trajectory];
x: Outline => RETURN[$outline];
ENDCASE;
IF a=NIL THEN RETURN[Type[NonNIL[a]]]
ELSE RETURN[$other];
};


maxIdLength: NAT ~ 1000;

IdentifierFromRope: PUBLIC PROC[rope: ROPE] RETURNS[Identifier] ~ {
size: INT ~ rope.Size[];
IF size>maxIdLength THEN {
MasterError[$limitExceeded, IO.PutFR["\"%g...\" is too long for an Identifier.",
IO.rope[rope.Substr[len: 20]]]];
ERROR Error;
}
ELSE {
atom: ATOM _ NIL;
illegal: BOOL _ FALSE;
scratch: REF TEXT ~ RefText.ObtainScratch[size];
{ ENABLE UNWIND => RefText.ReleaseScratch[scratch];
text: REF TEXT ~ RefText.AppendRope[to: scratch, from: rope];
FOR i: NAT IN[0..text.length) DO
SELECT text[i] FROM
IN['a..'z] => NULL;
IN['A..'Z] => text[i] _ text[i]+('a-'A); -- map upper case to lower case
IN['0..'9], '- => IF i=0 THEN illegal _ TRUE;
ENDCASE => { illegal _ TRUE; text[i] _ '-; }; -- map illegal chars to "-"
ENDLOOP;
atom _ Atom.MakeAtomFromRefText[text];
};
RefText.ReleaseScratch[scratch];
IF illegal THEN {
MasterWarning[$illegalIdentifier, IO.PutFR["\"%g\" is an illegal Identifier.",
IO.rope[rope]]];
};
RETURN[NEW[IdentifierRep _ [atom: atom, rope: rope]]];
};
};

RopeFromIdentifier: PUBLIC PROC[id: Identifier] RETURNS[rope: ROPE] ~ {
RETURN[id.rope];
};

<<NameFromVector: PUBLIC PROC[v: Vector] RETURNS[name: Name _ NIL] ~ {>>
<<shape: VectorShape ~ Shape[v];>>
<<FOR i: Integer DECREASING IN[shape.l .. shape.l+shape.n) DO>>
<<name _ CONS[IdentifierFromAny[Get[v, i]], name];>>
<<ENDLOOP;>>
<<};>>
<<>>
<<VectorFromName: PUBLIC PROC[name: Name] RETURNS[Vector] ~ {>>
<<ERROR;>>
<<};>>
<<>>
END.