DIRECTORY Atom, Basics, IO, NumTypes, Rope, RoseCreate, RoseTranslateTypes, RoseTypes, SignalTypeRegistration, SwitchNumConvert, VFonts;

NumTypesImpl: CEDAR PROGRAM
IMPORTS Atom, Basics, IO, Rope, RoseCreate, RoseTranslateTypes, SignalTypeRegistration, SwitchNumConvert, VFonts
EXPORTS NumTypes =

BEGIN OPEN RoseTypes, NumTypes;

boolProcs: NodeProcs _ NEW [NodeProcsRep _ [
Bits: BoolBits,
MesaUse: BoolMesaUse,
UserDescription: BoolUserDescription,
MesaDescription: BoolMesaDescription,
ListFormats: BoolListFormats,
GetFormat: BoolGetFormat,
MakeTransducer: MakeNumSwitchTransducer]];

boolType: PUBLIC NodeType _ NEW [NodeTypeRep[atom] _ [
procs: boolProcs,
typeData: NIL,
simple: TRUE,
structure: atom[]]];

onlyBoolFormat: Format _ NEW [FormatRep _ [
FormatValue: BoolFormatValue,
ParseValue: BoolParseValue,
FormatTest: BoolFormatTest,
ParseTest: BoolParseTest,
MaxWidth: BoolMaxWidth,
key: "bool"]];

Int: TYPE = REF INT;

one: Int _ NEW [INT _ 1];

ConstructBitType: RoseTranslateTypes.NodeTypeConstructor--PROC [parms: REF ANY - -UNION [BindingList, Args]- -] RETURNS [type: NodeType]-- =
BEGIN
type _ boolType;
END;

BoolBits: PROC [NodeType] RETURNS [INTEGER] = {RETURN [1]};
BoolMesaUse: PROC [NodeType] RETURNS [m: Mesa] = {m _ ["BOOLEAN"]};
BoolUserDescription: PROC [NodeType] RETURNS [r: ROPE] = {r _ "BOOL"};
BoolMesaDescription: PROC [NodeType] RETURNS [m: Mesa] =
{m _ [mesa: "NumTypes.boolType", imports: LIST["NumTypes"]]};
BoolListFormats: PROC [NodeType] RETURNS [l: RopeList] = {l _ LIST ["bool"]};
BoolGetFormat: PROC [NodeType, ROPE] RETURNS [f: Format] =
{f _ onlyBoolFormat};

BoolFormatValue: PROC [node: Node, fmt: Format, wp: WordPtr] RETURNS [r: ROPE] =
TRUSTED {r _ IF wp^ MOD 2 > 0 THEN "TRUE" ELSE "FALSE"};

BoolParseValue: PROC [node: Node, fmt: Format, wp: WordPtr, s: STREAM] RETURNS [success: BOOLEAN] = {
b: BOOLEAN;
success _ TRUE;
b _ s.GetBool[!IO.EndOfStream, IO.Error => {success _ FALSE; CONTINUE}];
IF NOT success THEN RETURN;
TRUSTED {wp^ _ IF b THEN LAST[CARDINAL] ELSE 0};
};

BoolFormatTest: PROC [nt: NodeType, fmt: Format, tp: NodeTestProc, td: NodeTestData] RETURNS [r: ROPE] =
BEGIN
r _ SELECT td FROM $True => "TRUE", $False => "FALSE", ENDCASE => "??";
END;

BoolParseTest: PROC [nt: NodeType, fmt: Format, s: STREAM] RETURNS [success: BOOLEAN, tp: NodeTestProc, td: NodeTestData] =
BEGIN
b: BOOLEAN;
success _ TRUE;
b _ s.GetBool[!IO.EndOfStream, IO.Error => {success _ FALSE; CONTINUE}];
IF NOT success THEN RETURN;
tp _ BoolTest;
td _ IF b THEN $True ELSE $False;
END;

BoolTest: NodeTestProc--PROC [where: WordPtr, testData: NodeTestData, nodeType: NodeType] RETURNS [passes: BOOLEAN]-- =
BEGIN
it: ATOM;
TRUSTED {it _ IF where^ MOD 2 > 0 THEN $True ELSE $False};
passes _ it = testData;
END;

BoolMaxWidth: PROC [nt: NodeType, fmt: Format, font: VFonts.Font] RETURNS [INT] =
{RETURN [VFonts.StringWidth["FALSE", font]]};

CeilDiv: PROC [num, den: INTEGER] RETURNS [quot: INTEGER] = {
IF den <= 0 THEN ERROR;
SELECT num FROM
= 0 => quot _ 0;
< 0 => quot _ num/den;
> 0 => quot _ (num + (den-1))/den;
ENDCASE => ERROR};

FloorDiv: PROC [num, den: INTEGER] RETURNS [quot: INTEGER] = {
IF den <= 0 THEN ERROR;
SELECT num FROM
= 0 => quot _ 0;
> 0 => quot _ num/den;
< 0 => quot _ (num - (den-1))/den;
ENDCASE => ERROR};

MakeNumSwitchTransducer: PROC [myKind, otherKind: Node, within: Cell, writeMine, writeOther: BOOLEAN] RETURNS [t: Cell] =
{t _ SwitchNumConvert.MakeTransducer[switchy: otherKind, nummy: myKind, within: within, writeSwitchy: writeOther, writeNummy: writeMine]};

NodeTypeList: TYPE = LIST OF ArrayNodeType;

numTypes: NodeTypeList _ NIL;

NumType: PUBLIC PROC [bits: CARDINAL] RETURNS [nt: NodeType] =
BEGIN
last: INTEGER _ bits-1;
FOR it: NodeTypeList _ numTypes, it.rest WHILE it # NIL DO
IF (it.first.first = 0) AND (it.first.last = last) THEN RETURN [it.first];
ENDLOOP;
numTypes _ CONS[nt _ MakeNumOfIndices[0, last], numTypes];
END;

BitArray: PUBLIC PROC [firstIndex, lastIndex: INTEGER] RETURNS [nt: NodeType] =
BEGIN
FOR it: NodeTypeList _ numTypes, it.rest WHILE it # NIL DO
IF (it.first.first = firstIndex) AND (it.first.last = lastIndex) THEN RETURN [it.first];
ENDLOOP;
numTypes _ CONS[nt _ MakeNumOfIndices[firstIndex, lastIndex], numTypes];
END;

MakeNumOfIndices: PROC [firstIndex, lastIndex: INTEGER] RETURNS [nt: ArrayNodeType] =
BEGIN
nt _ NEW [NodeTypeRep[array] _ [
procs: numProcs,
typeData: NIL,
simple: TRUE,
structure: array[firstIndex, lastIndex, boolType]]];
END;

numProcs: NodeProcs _ NEW [NodeProcsRep _ [
Bits: NumBits,
MesaUse: NumMesaUse,
UserDescription: NumUserDescription,
MesaDescription: NumMesaDescription,
ListFormats: NumListFormats,
GetFormat: NumGetFormat,
MakeSubarrayType: NumMakeSubarrayType,
MakeSplitJoin: NumMakeSplitJoin,
MakeTransducer: MakeNumSwitchTransducer]];

ConstructNumType: RoseTranslateTypes.NodeTypeConstructor--PROC [parms: REF ANY - -UNION [BindingList, Args]- -] RETURNS [type: NodeType]-- =
BEGIN
bits: Int _ NARROW[RoseTranslateTypes.GetParm[n: 1, name: "bits", parms: parms, default: one]];
type _ NumType[bits^];
END;

NumBits: PROC [nt: NodeType] RETURNS [bits: INTEGER] = {
ant: ArrayNodeType _ NARROW[nt];
bits _ 1 + ant.last - ant.first;
bits _ SELECT bits FROM
<= 16 => bits,
> 16 => 16 * CeilDiv[1 + ant.last - ant.first, 16],
ENDCASE => ERROR};

NumMesaUse: PROC [nt: NodeType] RETURNS [m: Mesa] = {
ant: ArrayNodeType _ NARROW[nt];
bits: INTEGER _ 1 + ant.last - ant.first;
m _ [SELECT bits FROM
< 16 => IO.PutFR["[0..%g]", IO.card[uppers[bits]]],
= 16 => "CARDINAL",
> 16 => IO.PutFR["ARRAY [0..%g) OF CARDINAL", IO.card[CeilDiv[bits, 16]]],
ENDCASE => ERROR]};

uppers: ARRAY [1..16] OF CARDINAL = [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767, 65535];

NumUserDescription: PROC [nt: NodeType] RETURNS [ud: ROPE] = {
ant: ArrayNodeType _ NARROW[nt];
ud _ IF ant.first = 0
THEN IO.PutFR["INT[%g]", IO.int[ant.last+1]]
ELSE IO.PutFR["Num[%g .. %g]", IO.card[ant.first], IO.card[ant.last]]};

NumMesaDescription: PROC [nt: NodeType] RETURNS [m: Mesa] = {
ant: ArrayNodeType _ NARROW[nt];
m _ [
mesa: IF ant.first = 0
THEN IO.PutFR["NumTypes.NumType[%g]", IO.int[ant.last+1]]
ELSE IO.PutFR["NumTypes.BitArray[%g, %g]", IO.int[ant.first], IO.int[ant.last]],
imports: LIST["NumTypes"]]};

NumListFormats: PROC [NodeType] RETURNS [l: RopeList] = {
l _ LIST ["2", "8", "10", "16"]};

NumGetFormat: PROC [nt: NodeType, key: ROPE] RETURNS [fmt: Format] = {
atom: ATOM _ Atom.MakeAtom[key];
fmt _ NARROW[Atom.GetProp[atom: atom, prop: numFmtKey]];
};

numFmtKey: REF ROPE _ NEW [ROPE _ "Numeric Format Key"];

NumMakeSubarrayType: PROC [nt: NodeType, first, last: INTEGER] RETURNS [st: NodeType] =
BEGIN
st _ BitArray[first, last];
END;

Numeric: PUBLIC PROC [nt: NodeType] RETURNS [numeric: BOOLEAN] = {
WITH nt SELECT FROM
ant: ArrayNodeType => numeric _ Numeric[ant.element];
ant: AtomNodeType => numeric _ ant = boolType;
ENDCASE => ERROR};

Side: TYPE = {A, B};

NumMakeSplitJoin: PROC [within: Cell, a, b: StretchList, writeA, writeB: BOOLEAN] RETURNS [cell: Cell] =
BEGIN
Add: PROC [old, sep, nu1, nu2, nu3: ROPE _ NIL] RETURNS [new: ROPE] =
BEGIN
new _ old.Cat[IF old.Length[] > 0 THEN sep ELSE "", nu1, nu2, nu3];
END;
Hello: PROC [stretch: Stretch, side: Side] RETURNS [length: INTEGER] =
{oside: Side _ IF side = A THEN B ELSE A;
bits: INTEGER _ stretch.node.type.procs.Bits[stretch.node.type];
words: INTEGER _ (bits + 15)/16;
portName: ROPE _ IO.PutFR["%g%g",
IO.rope[SELECT side FROM A => "A", B => "B", ENDCASE => ERROR],
IO.int[portCount[side] _ portCount[side]+1]];
bitOff: INTEGER _ 0;
IF NOT Numeric[stretch.node.type] THEN ERROR;
WITH stretch SELECT FROM
ss: SubStretch => BEGIN
WITH stretch.node.type SELECT FROM
ant: ArrayNodeType => BEGIN
goodBits: INTEGER = 1 + ant.last - ant.first;
inRepFiller: INTEGER _ (16 - (goodBits MOD 16)) MOD 16;
IF ant.element # boolType THEN ERROR;
IF ss.first < ant.first OR ss.last > ant.last THEN ERROR;
bitOff _ inRepFiller + ss.first - ant.first;
END;
ant: AtomNodeType => ERROR;
ENDCASE => ERROR;
length _ 1 + ss.last - ss.first;
END;
ss: SingleStretch => WITH stretch.node.type SELECT FROM
ant: ArrayNodeType => ERROR;
ant: AtomNodeType => length _ 1;
ENDCASE => ERROR;
ENDCASE => ERROR;
connections _ Add[connections, ", ", portName, ":", stretch.node.name];
instanceNames[side] _ Add[instanceNames[side], ",", stretch.node.name];
classNames[side] _ Add[classNames[side], ",", stretch.node.type.procs.UserDescription[stretch.node.type]];
wordOffset[side] _ nextWordOffset;
nextWordOffset _ nextWordOffset + words;
portList _ CONS[
[wordOffset[side], words, portName, stretch.node.type, write[oside], write[side]],
portList];
bitOffset[side] _ ((16 - (bits MOD 16)) MOD 16) + bitOff;
};
sjd: SplitJoinData _ NEW [SplitJoinDataRep _ []];
connections: ROPE;
instanceNames, classNames: ARRAY Side OF ROPE _ ALL[NIL];
wordOffset, bitOffset, portCount: ARRAY Side OF INTEGER _ ALL[0];
nextWordOffset: INTEGER _ 1;
write: ARRAY Side OF BOOLEAN = [writeA, writeB];
portList: LIST OF Port;
aList, bList: StretchList;
aLength, bLength: INTEGER;
exhausted: BOOLEAN _ FALSE;
sjd.direction _ IF writeA
THEN (IF writeB THEN ERROR ELSE toA)
ELSE (IF writeB THEN toB ELSE ERROR);
aLength _ Hello[(aList _ a).first, A];
bLength_ Hello[(bList _ b).first, B];
WHILE NOT exhausted DO
length: INTEGER _ MIN[aLength, bLength];
sjd.parts _ CONS[
[
aWordOffset: wordOffset[A], aBitOffset: bitOffset[A],
bWordOffset: wordOffset[B], bBitOffset: bitOffset[B],
length: length],
sjd.parts];
bitOffset[A] _ bitOffset[A] + length;
bitOffset[B] _ bitOffset[B] + length;
aLength _ aLength - length;
bLength _ bLength - length;
IF aLength = 0 THEN
BEGIN
aList _ aList.rest;
IF aList = NIL THEN exhausted _ TRUE ELSE aLength _ Hello[aList.first, A];
END;
IF bLength = 0 THEN
BEGIN
bList _ bList.rest;
IF bList = NIL THEN exhausted _ TRUE ELSE bLength _ Hello[bList.first, B];
END;
ENDLOOP;
IF aLength # 0 OR aList # NIL OR bLength # 0 OR bList # NIL THEN ERROR;
sjd.words _ nextWordOffset - 1;
cell _ RoseCreate.CreateCell[
within: within,
instanceName: IO.PutFR[
"[%g]-[%g]",
IO.rope[instanceNames[A]],
IO.rope[instanceNames[B]]],
className: EnsureSplitJoin[
portList,
portCount[A]+portCount[B],
IO.PutFR["NumSplitter[%g]%g-%g[%g]",
IO.rope[classNames[A]],
IO.rope[IF writeA THEN "<" ELSE ""],
IO.rope[IF writeB THEN ">" ELSE ""],
IO.rope[classNames[B]]]].name,
interfaceNodes: connections,
initData: sjd];
END;

SplitJoinDataList: TYPE = LIST OF SplitJoinDataRep;
SplitJoinData: TYPE = REF SplitJoinDataRep;
SplitJoinDataRep: TYPE = RECORD [
parts: PartList _ NIL,
words: INTEGER _ 0,
direction: Direction _ toB];

Direction: TYPE = {toA, toB};

PartList: TYPE = LIST OF Part;
Part: TYPE = RECORD [
aWordOffset, bWordOffset, aBitOffset, bBitOffset, length: INTEGER
];

splitters: LIST OF CellClass _ NIL;

EnsureSplitJoin: PROC [portList: LIST OF Port, portCount: CARDINAL, className: ROPE] RETURNS [class: CellClass] =
BEGIN
ports: Ports;
pl: LIST OF Port;
FOR cl: LIST OF CellClass _ splitters, cl.rest WHILE cl # NIL DO
i: CARDINAL;
class _ cl.first;
IF class.ports.length # portCount THEN LOOP;
pl _ portList;
FOR i IN [0 .. portCount) DO
IF pl.first # class.ports[i] THEN EXIT;
pl _ pl.rest;
ENDLOOP;
IF i < portCount THEN LOOP;
IF pl # NIL THEN ERROR;
RETURN;
ENDLOOP;
ports _ NEW [PortsRep[portCount]];
pl _ portList;
FOR i: CARDINAL IN [0 .. portCount) DO
ports[i] _ pl.first;
pl _ pl.rest;
ENDLOOP;
class _ RoseCreate.RegisterCellClass[className: className, ioCreator: CreateSplitterIO, initializer: InitializeSplitter, evals: [EvalSimple: EvalSplitter], ports: ports];
splitters _ CONS[class, splitters];
END;

Words: TYPE = REF WordsRep;
WordsRep: TYPE = RECORD [words: SEQUENCE length: CARDINAL OF CARDINAL];

Bits: TYPE = LONG POINTER TO PACKED ARRAY CARDINAL OF BOOLEAN;

CreateSplitterIO: IOCreator--PROC [cell: Cell, initData: REF ANY]-- =
BEGIN
sjd: SplitJoinData _ NARROW[initData];
cell.realCellStuff.newIO _ NEW [WordsRep[sjd.words]];
cell.realCellStuff.oldIO _ NEW [WordsRep[sjd.words]];
END;

InitializeSplitter: Initializer--PROCEDURE [cell: Cell, initData: REF ANY, leafily: BOOLEAN]-- = {cell.realCellStuff.state _ initData};

EvalSplitter: CellProc--PROC [cell: Cell]-- = TRUSTED
BEGIN
sjd: SplitJoinData _ NARROW[cell.realCellStuff.state];
new: Words _ NARROW[cell.realCellStuff.newIO];
old: Words _ NARROW[cell.realCellStuff.oldIO];
a, b: Bits;
FOR pl: PartList _ sjd.parts, pl.rest WHILE pl # NIL DO
p: Part _ pl.first;
a _ LOOPHOLE[cell.realCellStuff.newIOAsWP + p.aWordOffset];
b _ LOOPHOLE[cell.realCellStuff.newIOAsWP + p.bWordOffset];
SELECT sjd.direction FROM
toA => FOR i: INTEGER IN [0 .. p.length) DO
a[p.aBitOffset+i] _ b[p.bBitOffset+i] ENDLOOP;
toB => FOR i: INTEGER IN [0 .. p.length) DO
b[p.bBitOffset+i] _ a[p.aBitOffset+i] ENDLOOP;
ENDCASE => ERROR;
ENDLOOP;
END;

NumFormatValue: PROC [node: Node, fmt: Format, wp: WordPtr] RETURNS [rope: ROPE] =
BEGIN
ant: ArrayNodeType _ NARROW[node.type];
wordWidth: CARDINAL _ (ant.last - ant.first + 16)/16;
base: CARDINAL _ NARROW[fmt.formatData, REF CARDINAL]^;
bitsPerDigitTimes10: CARDINAL _ bitsPerBaseTimes10[base];
digits: CARDINAL _ ((ant.last + 1 - ant.first)*10 + bitsPerDigitTimes10 - 1) / bitsPerDigitTimes10;
v: Value _ ValueFromWP[wp, wordWidth];
rope _ baseKeys[base];
FOR i: CARDINAL IN [1 .. digits] DO
rem: CARDINAL;
[v, rem] _ DivMod[v, base];
rope _ encode[rem].Concat[rope];
ENDLOOP;
END;

NumParseValue: PROC [node: Node, fmt: Format, wp: WordPtr, s: STREAM] RETURNS [success: BOOLEAN] =
BEGIN
ant: ArrayNodeType _ NARROW[node.type];
bits: CARDINAL _ ant.last - ant.first + 1;
wordWidth: CARDINAL _ (bits + 15)/16;
rope: ROPE _ s.GetTokenRope[IO.IDProc].token;
fb: REF CARDINAL _ NARROW[fmt.formatData];
base, test: CARDINAL;
dl, sign: INTEGER _ 1;
v: Value _ NEW [ValueRec[0]];
IF rope.Length[] < 1 THEN RETURN [FALSE]
ELSE BEGIN
SELECT rope.Fetch[rope.Length[] - 1] FROM
'b, 'B => {base _ 2; dl _ 1};
'o, 'O => {base _ 8; dl _ 1};
'd, 'D => {base _ 10; dl _ 1};
'h, 'H => {base _ 16; dl _ 1};
ENDCASE => {base _ fb^; dl _ 0};
FOR i: INT IN [0 .. rope.Length[] - dl) DO
c: CHARACTER _ rope.Fetch[i];
IF c = '- THEN sign _ -sign
ELSE BEGIN
d: [0..16] _ decode[c];
IF d > base THEN RETURN [FALSE];
v _ Add[Multiply[v, base], d];
END;
ENDLOOP;
END;
IF v.length > wordWidth THEN RETURN [FALSE];
IF wordWidth < 1 THEN RETURN [TRUE];
v _ Truncate[v, wordWidth];
test _ Basics.BITAND[v[0], verboten[bits MOD 16]];
IF 0 # test THEN RETURN [FALSE];
ValueToWP[v, wp, wordWidth];
success _ TRUE;
END;

MaskedValue: TYPE = REF MaskedValueRep;
MaskedValueRep: TYPE = RECORD [m, v: Value];

NumFormatTest: PROC [nt: NodeType, fmt: Format, tp: NodeTestProc, td: NodeTestData] RETURNS [rope: ROPE] =
BEGIN
ant: ArrayNodeType _ NARROW[nt];
bits: CARDINAL _ ant.last - ant.first + 1;
mv: MaskedValue _ NARROW[td];
IF mv = NIL THEN rope _ "??"
ELSE rope _ EncodeMV[mv.m, mv.v, 16, bits !CantEncode => {rope _ EncodeMV[mv.m, mv.v, 2, bits]; CONTINUE}];
rope _ Rope.Cat["=", rope];
END;

NumParseTest: PROC [nt: NodeType, fmt: Format, s: STREAM] RETURNS [success: BOOLEAN, tp: NodeTestProc, td: NodeTestData] =
BEGIN
ant: ArrayNodeType _ NARROW[nt];
bits: CARDINAL _ ant.last - ant.first + 1;
wordWidth: CARDINAL _ (bits + 15)/16;
base, test: CARDINAL;
dl, sign: INTEGER _ 1;
v: Value _ NEW [ValueRec[0]];
m: Value _ NEW [ValueRec[0]];
rope: ROPE _ s.GetTokenRope[IO.IDProc].token;
IF rope.Length[] < 1 THEN RETURN [FALSE, NIL, NIL]
ELSE BEGIN
SELECT rope.Fetch[rope.Length[] - 1] FROM
'b, 'B => {base _ 2; dl _ 1};
'o, 'O => {base _ 8; dl _ 1};
'd, 'D => {base _ 10; dl _ 1};
'h, 'H => {base _ 16; dl _ 1};
IN ['2..'9] => {base _ 10; dl _ 0};
'a, 'A, 'c, 'C, 'e, 'E, 'f, 'F => {base _ 16; dl _ 0};
ENDCASE => {base _ 2; dl _ 0};
FOR i: INT IN [0 .. rope.Length[] - dl) DO
c: CHARACTER _ rope.Fetch[i];
v _ Multiply[v, base];
m _ Multiply[m, base];
IF c = 'x OR c = 'X THEN
BEGIN
m _ Add[m, base-1];
END
ELSE BEGIN
d: [0..16] _ decode[c];
IF d > base THEN RETURN [FALSE, NIL, NIL];
v _ Add[v, d];
END;
ENDLOOP;
END;
IF MAX[v.length, m.length] > wordWidth THEN RETURN [FALSE, NIL, NIL];
IF wordWidth < 1 THEN RETURN [FALSE, NIL, NIL];
v _ Truncate[v, wordWidth];
m _ Truncate[m, wordWidth];
test _ Basics.BITAND[v[0], verboten[bits MOD 16]];
IF 0 # test THEN RETURN [FALSE, NIL, NIL];
test _ Basics.BITAND[m[0], verboten[bits MOD 16]];
IF 0 # test THEN RETURN [FALSE, NIL, NIL];
td _ NEW [MaskedValueRep _ [m: m, v: v]];
success _ TRUE;
tp _ TestInt;
END;

NumMaxWidth: PROC [nt: NodeType, fmt: Format, font: VFonts.Font] RETURNS [INT] =
BEGIN
ant: ArrayNodeType _ NARROW[nt];
base: CARDINAL _ NARROW[fmt.formatData, REF CARDINAL]^;
bitsPerDigitTimes10: CARDINAL _ bitsPerBaseTimes10[base];
digits: CARDINAL _ ((ant.last + 1 - ant.first)*10 + bitsPerDigitTimes10 - 1) / bitsPerDigitTimes10;
RETURN [VFonts.StringWidth["X", font]*digits + VFonts.StringWidth[baseKeys[base]]]
END;

CantEncode: ERROR = CODE;

EncodeMV: PROC [m, v: Value, base: [2..16], bits: CARDINAL] RETURNS [rope: ROPE] =
BEGIN
digits: CARDINAL _ (bits + base - 1)/base;
rope _ IF base = 16 THEN "H" ELSE IF base = 2 THEN "B" ELSE ERROR;
FOR i: CARDINAL IN [1 .. digits] DO
vRem, mRem: CARDINAL;
[v, vRem] _ DivMod[v, base];
[m, mRem] _ DivMod[m, base];
IF mRem = 0 THEN rope _ encode[vRem].Concat[rope]
ELSE IF mRem+1 = base THEN rope _ Rope.Concat["X", rope]
ELSE ERROR CantEncode[];
ENDLOOP;
END;

TestInt: NodeTestProc--PROC [where: WordPtr, testData: NodeTestData, nodeType: NodeType] RETURNS [passes: BOOLEAN]-- = TRUSTED
BEGIN
ant: ArrayNodeType _ NARROW[nodeType];
bits: CARDINAL _ ant.last - ant.first + 1;
mv: MaskedValue _ NARROW[testData];
other: CARDINAL _ verboten[bits MOD 16];
wordCount: CARDINAL _ (bits+15)/16;
wmo: CARDINAL _ wordCount - 1;
IF wordCount < 1 THEN ERROR;
IF wordCount # mv.v.length THEN RETURN [FALSE];
IF wordCount # mv.m.length THEN RETURN [FALSE];
FOR i: CARDINAL IN [0..wordCount) DO
diff: CARDINAL _ Basics.BITXOR[mv.v[i], (where+i)^];
diff _ Basics.BITAND[diff, Basics.BITNOT[Basics.BITOR[other, mv.m[i]]]];
IF diff # 0 THEN RETURN [FALSE];
other _ 0;
ENDLOOP;
passes _ TRUE;
END;

baseKeys: ARRAY [2 .. 16] OF ROPE = ["B", "R3", "R4", "R5", "R6", "R7", "O", "R9", "D", "R11", "R12", "R13", "R14", "R15", "H"];

bitsPerBaseTimes10: ARRAY [2 .. 16] OF CARDINAL = [10, 15, 20, 23, 25, 28, 30, 31, 32, 34, 35, 37, 38, 39, 40];

decode: ARRAY CHARACTER OF [0..16] _ ALL[16];

encode: ARRAY [0..16) OF ROPE = ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F"];

verboten: ARRAY [0..16) OF CARDINAL _ [65535-65535, 65535-1, 65535-3, 65535-7, 65535-15, 65535-31, 65535-63, 65535-127, 65535-255, 65535-511, 65535-1023, 65535-2047, 65535-4095, 65535-8191, 65535-16383, 65535-32767];

ValueToWP: PROC [v: Value, wp: WordPtr, words: CARDINAL] = TRUSTED
BEGIN
IF words < 1 THEN ERROR;
FOR i: CARDINAL IN [0..words) DO (wp+i)^ _ v[i] ENDLOOP;
END;

ValueFromWP: PROC [wp: WordPtr, words: CARDINAL] RETURNS [v: Value] = TRUSTED
BEGIN
IF words < 1 THEN ERROR;
v _ NEW [ValueRec[words]];
FOR i: CARDINAL IN [0..words) DO v[i] _ (wp+i)^ ENDLOOP;
END;

Value: TYPE = REF ValueRec;
ValueRec: TYPE = RECORD [chunks: SEQUENCE length: CARDINAL OF CARDINAL];

Multiply: PROC [v: Value, f: CARDINAL] RETURNS [p: Value] =
BEGIN
prod: LONG CARDINAL _ 0;
p _ NEW [ValueRec[v.length + 1]];
FOR i: CARDINAL DECREASING IN [0..p.length) DO
IF i > 0 THEN prod _ prod + LONG[v[i-1]] * f;
p[i] _ prod MOD 65536;
prod _ prod / 65536;
ENDLOOP;
p _ Truncate[p, Significance[p]];
END;

DivMod: PROC [v: Value, d: CARDINAL] RETURNS [q: Value, rem: CARDINAL] =
BEGIN
r: LONG CARDINAL _ 0;
q _ NEW[ValueRec[v.length]];
FOR i: CARDINAL IN [0..v.length) DO
prod: LONG CARDINAL _ d;
r _ r * 65536 + v[i];
q[i] _ r/d;
r _ r - prod * q[i];
ENDLOOP;
rem _ r;
q _ Truncate[q, Significance[q]];
END;

Add: PROC [v: Value, s: CARDINAL] RETURNS [w: Value] =
BEGIN
carry: LONG CARDINAL _ s;
w _ NEW[ValueRec[v.length + 1]];
FOR i: CARDINAL DECREASING IN [0..w.length) DO
IF i > 0 THEN carry _ carry + v[i-1];
w[i] _ carry MOD 65536;
carry _ carry / 65536;
ENDLOOP;
w _ Truncate[w, Significance[w]];
END;

Significance: PROC [v: Value] RETURNS [s: CARDINAL] =
BEGIN
FOR s IN [0..v.length) DO
IF v[s] # 0 THEN RETURN [v.length - s];
ENDLOOP;
s _ 0;
END;

Truncate: PROC [v: Value, len: CARDINAL] RETURNS [w: Value] =
BEGIN
w _ NEW [ValueRec[len]];
FOR i: CARDINAL IN (0..len] DO
w[len - i] _ IF i <= v.length THEN v[v.length - i] ELSE 0;
ENDLOOP;
END;

lowMask: ARRAY [1..16] OF CARDINAL;

IntNot: PUBLIC PROC [bitWidth: [1..16], bits: CARDINAL] RETURNS [inverted: CARDINAL] =
BEGIN
inverted _ Basics.BITAND[Basics.BITNOT[bits], lowMask[bitWidth]];
END;

AddFormat: PROC [key: ROPE, base: CARDINAL] =
BEGIN
atom: ATOM _ Atom.MakeAtom[key];
Atom.PutProp[atom: atom, prop: numFmtKey, val: NEW [FormatRep _ [
FormatValue: NumFormatValue,
ParseValue: NumParseValue,
FormatTest: NumFormatTest,
ParseTest: NumParseTest,
MaxWidth: NumMaxWidth,
formatData: NEW [CARDINAL _ base],
key: key]]];
END;

Setup: PROC =
BEGIN
n: CARDINAL _ 0;
FOR i: CARDINAL IN [1 .. 16] DO
lowMask[i] _ n _ n + n + 1;
ENDLOOP;
FOR c: CARDINAL IN [0..9] DO
decode['0 + c] _ c;
ENDLOOP;
FOR c: CARDINAL IN [0..5] DO
decode['A + c] _ 10 + c;
decode['a + c] _ 10 + c;
ENDLOOP;
AddFormat["2", 2];
AddFormat["8", 8];
AddFormat["10", 10];
AddFormat["16", 16];
AddFormat["", 16];
SignalTypeRegistration.RegisterNodeTypeConstructor["INT", ConstructNumType];
SignalTypeRegistration.RegisterNodeTypeConstructor["BOOL", ConstructBitType];
SignalTypeRegistration.SetDefaultNodeType["BOOL"];
END;

Setup[];

END.
ΰNumTypesImpl.Mesa, from [Indigo]<Rosemary>2.3>Rosemary2.DF
Last Edited by: Spreitzer, April 18, 1984 11:03:05 am PST
'a, 'A, 'c, 'C, 'e, 'E, 'f, 'F => {base _ 16; dl _ 0};
increasing index <=> decreasing significance
ΚΘ˜J™:J™9Icode˜KšΟk	œ˜ˆ
K˜šΠbxœœ
˜Kšœi˜pKšœ˜—K˜Kšœ
œ˜K˜šœœ˜,K˜K˜Kš
œ%˜%Kš
œ%˜%K˜Kš
œ˜Kš
œ*˜*—K˜šœ
œœ˜6K˜Kšœ
œ
˜Kšœœ
˜
K˜—K˜šœœ˜+Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜—K˜Kšœœœ
œ
˜K˜Kšœœœ˜K˜šΟnœ(ΟcRœ˜Œ
Kš
˜K˜Kšœ
˜—K˜Kš
Ÿœœœœœ˜;KšŸœœœ˜CKšŸœœœœ˜FšŸœœœ˜8Kšœ*œ˜=—KšŸœœœœ˜MšŸ
œœœœ˜:Kš
œ˜—K˜šŸœœ(œœ˜PKš
œœœœœ
˜8—K˜š
Ÿœœ+œœœ˜eKšœœ
˜Kšœ
œ
˜Kš	œœœœœ˜HKšœ
œ	œ
œ
˜Kšœœœ
œ
œœ˜0Kš
œ˜—K˜šŸœœAœœ˜hKš
˜Kšœœœ%œ	˜GKšœ
˜—K˜š
Ÿ
œœ œœœ'˜{Kš
˜Kšœœ
˜Kšœ
œ
˜Kš	œœœœœ˜HKšœ
œ	œ
œ
˜K˜Kšœœœœ˜!Kšœ
˜—K˜šŸœ _œ˜wKš
˜Kšœœ
˜	Kš
œœœœœ	˜:K˜Kšœ
˜—K˜šŸœœ0œœ˜QKšœ
œ&˜-—K˜š
Ÿœœœœœ˜=Kšœ
œ
œ
˜šœ˜K˜K˜K˜"Kšœœ˜——K˜š
Ÿœœœœœ˜>Kšœ
œ
œ
˜šœ˜K˜K˜K˜"Kšœœ˜——K˜šŸœœ@œœ˜yKš
œŠ
˜Š
—K˜Kšœœœ
œ˜+K˜Kšœœ
˜K˜š
Ÿœœ
œœœ˜>Kš
˜Kšœœ
˜šœ&œœ
˜:Kšœœœ
œ˜JKšœ
˜—Kšœœ+˜:Kšœ
˜—K˜š
Ÿœœ
œœœ˜OKš
˜šœ&œœ
˜:Kšœœœ
œ˜XKšœ
˜—Kšœœ9˜HKšœ
˜—K˜šŸœœœœ˜UKš
˜šœœ˜ K˜Kšœ
œ
˜Kšœœ
˜
Kš
œ4˜4—Kšœ
˜—K˜šœœ˜+Kš
œ˜Kš
œ˜Kš
œ$˜$Kš
œ$˜$K˜Kš
œ˜Kš
œ&˜&Kš
œ ˜ Kš
œ*˜*—K˜šŸœ( Rœ˜Œ
Kš
˜KšœœM˜_K˜Kšœ
˜—K˜šŸœœœœ˜8Kšœœ˜ Kš
œ ˜ šœœ˜Kš
œ˜Kš
œ3˜3Kšœœ˜——K˜šŸ
œœœ˜5Kšœœ˜ Kšœœ˜)šœœ˜Kšœœœ˜3K˜Kšœœ$œ˜JKšœœ˜——K˜Kšœœ	œ
œU˜vK˜šŸœœœœ˜>Kšœœ˜ šœœ˜Kšœ
œœ˜,Kšœ
œœœ˜G——K˜šŸœœœ˜=Kšœœ˜ š
œ˜šœœ˜Kšœ
œœ˜9Kšœ
œ$œœ˜P—Kšœ	œ˜——K˜šŸœœœ˜9Kšœœ˜!—K˜šŸœœœœ˜FKšœœ˜ Kšœœ,˜8K˜—K˜Kš	œœ
œœœ˜8K˜šŸœœœœ˜WKš
˜K˜Kšœ
˜—K˜š
Ÿœœ
œœœ˜Bšœœ
˜K˜5K˜.Kšœœ˜——K˜Kšœœ
œ
œ˜K˜šŸœœ3œœ˜hKš
˜šŸœœœœœœ˜EKš
˜Kšœœœœ˜CKšœ
˜—šŸœœ œ
œ˜FKš
œœ
œ
œ

œ
œ

œ
˜)Kšœœ3˜@Kšœœ˜ šœ
œœ˜!Kšœœœ

œ	
œ	œœ˜?Kšœ+˜-—Kšœœ˜Kšœ
œœ
œ
˜-šœ	œ
˜šœ˜šœœ
˜"šœ˜Kšœ
œ˜-Kšœ
œœœ˜7Kšœœ
œ
˜%Kšœœœ
œ
˜9Kš
œ,˜,Kšœ
˜—Kšœœ
˜Kšœœ
˜—Kš
œ ˜ Kšœ
˜—šœœœ
˜7Kšœœ
˜Kš
œ ˜ Kšœœ
˜—Kšœœ
˜—Kš
œG˜GKš
œG˜GKš
œj˜jK˜"K˜(šœœ
˜Kš
œR˜RK˜
—Kšœœœ˜9Kš
œ˜—Kšœœ˜1Kšœ
œ
˜Kšœœœ
œœ
œ˜9Kš	œ"œœ
œœ˜AKšœœ˜Kšœœœ
œ˜0Kšœ
œ
œ˜Kš
œ˜Kšœœ
˜Kšœœœ
˜šœœ˜Kš
œœœ
œ
œ˜$Kš
œœœœ
œ˜%—Kšœ#
œ˜&Kšœ"
œ˜%šœ
œ˜Kšœœœ˜(šœœ
˜˜
Kšœ
œ
œ˜5Kšœ
œ
œ˜5K˜—K˜—Kšœ

œ
œ˜%Kšœ

œ
œ˜%Kš
œ˜Kš
œ˜šœ
˜Kš
˜K˜Kšœ	œ
œ
œ
œ
œ˜JKšœ
˜—šœ
˜Kš
˜K˜Kšœ	œ
œ
œ
œ
œ˜JKšœ
˜—Kšœ
˜—Kšœ
œ	œ
œ
œ	œ
œ
œ
˜GK˜˜K˜šœœ˜K˜Kšœ
œ˜Kšœ
œ˜—š
œ˜Kš
œ	˜	Kšœ

œ
œ˜šœ"˜$Kšœ
œ˜Kšœœœœ˜$Kšœœœœ˜$Kšœ
œ
˜——Kš
œ˜Kš
œ˜—Kšœ
˜—K˜Kšœœœ
œ˜3Kšœœœ˜+šœœœ˜!Kšœœ
˜Kšœœ˜Kš
œ˜—K˜Kšœœ˜K˜Kšœ
œœ
œ˜šœœœ˜Kšœ:˜AK˜—K˜Kšœœ
œ
œ
˜#K˜šŸœœœ
œœ
œœ˜qKš
˜K˜
Kšœœ
œ˜šœœ
œ œœ
˜@Kšœœ
˜K˜Kšœ œ
œ
˜,Kš
œ˜šœœ˜Kšœœ
œ
˜'K˜
Kšœ
˜—Kšœœ
œ
˜Kšœœ
œ
œ
˜Kšœ
˜Kšœ
˜—Kšœœ˜"Kš
œ˜šœœ
œ˜&K˜K˜
Kšœ
˜—Kš
œͺ
˜ͺ
Kšœœ˜#Kšœ
˜—K˜Kšœœœ
˜Kš
œ
œœ	œ	œ
œ
œ˜GK˜Kšœœœ
œ
œ
œ
œ
œ
œ
œ
˜>K˜šŸœ (œ˜EKš
˜Kšœœ˜&Kšœœ˜5Kšœœ˜5Kšœ
˜—K˜KšŸœ
 ?œ)˜‡
K˜šŸœ
 œ˜5Kš
˜Kšœœ˜6Kšœ
œ˜.Kšœ
œ˜.K˜šœ#œœ
˜7K˜Kšœœ/˜;Kšœœ/˜;šœ˜šœœœ
œ˜+Kšœ&œ
˜.—šœœœ
œ˜+Kšœ&œ
˜.—Kšœœ
˜—Kšœ
˜—Kšœ
˜—K˜šŸœœ(œœ˜RKš
˜Kšœœ˜'Kšœœ"˜5Kš	œœœœ
œ˜7Kšœœ˜9KšœœS˜cKš
œ&˜&K˜šœœ
œ˜#Kšœœ
˜Kš
œ˜K˜ Kšœ
˜—Kšœ
˜—K˜š
Ÿ
œœ+œœœ˜bKš
˜Kšœœ˜'Kšœœ˜*Kšœœ˜%Kšœœœ˜-Kšœœ
œœ˜*Kšœœ
˜Kšœ
œ˜Kšœœ˜Kšœœ
œœ
˜(šœ
˜
šœ˜)K˜K˜K˜K˜K™6Kšœ˜ —šœœ
œ˜*Kšœ	œ˜Kšœœ
˜šœ
˜
K˜Kšœ
œ
œœ˜ Kš
œ˜Kšœ
˜—Kšœ
˜—Kšœ
˜—Kšœœ
œœ˜,Kšœœ
œœ˜$Kš
œ˜Kšœœœ˜2Kšœ
œ
œœ˜ Kš
œ˜Kšœ
œ
˜Kšœ
˜—K˜Kšœ
œœ˜'Kšœœœ˜,K˜šŸ
œœAœœ˜jKš
˜Kšœœ˜ Kšœœ˜*Kšœœ˜Kšœœ
œ˜Kšœ\œ˜kKš
œ˜Kšœ
˜—K˜š
Ÿœœ œœœ'˜zKš
˜Kšœœ˜ Kšœœ˜*Kšœœ˜%Kšœœ
˜Kšœ
œ˜Kšœœ˜Kšœœ˜Kšœœœ˜-Kšœœ
œœœœ
˜2šœ
˜
šœ˜)K˜K˜K˜K˜K˜#K˜6Kšœ˜—šœœ
œ˜*Kšœ	œ˜K˜K˜šœœ˜Kš
˜K˜Kš
˜—šœ
˜
K˜Kšœ
œ
œœœœ˜*Kš
œ˜Kšœ
˜—Kšœ
˜—Kšœ
˜—Kšœ
œ!œ
œœœœ˜EKšœœ
œœœœ˜/Kš
œ˜K˜Kšœœœ˜2Kšœ
œ
œœœœ˜*Kšœœœ˜2Kšœ
œ
œœœœ˜*Kšœœ!˜)Kšœ
œ
˜Kš
œ
˜
Kšœ
˜—K˜šŸœœ0œœ˜PKš
˜Kšœœ˜ Kš	œœœœ
œ˜7Kšœœ˜9KšœœS˜cKšœL˜RKšœ
˜—K˜Kšœœœ
˜K˜š
Ÿœœ$œœœ˜RKš
˜Kšœœ˜*Kšœœœœ
œ
œœ
œ
˜Bšœœ
œ˜#Kšœœ
˜Kš
œ˜Kš
œ˜Kšœ
œ!˜1Kšœ
œœ˜8Kšœ
œ˜Kšœ
˜—Kšœ
˜—K˜šŸœ _œ˜~Kš
˜Kšœœ˜&Kšœœ˜*Kšœœ˜#Kšœœœ˜(Kšœœ˜#Kšœœ˜Kšœœ
œ
˜Kšœœ
œœ˜/Kšœœ
œœ˜/šœœ
œ˜$Kšœœ
œ˜4Kšœœœœ˜HKšœ
œ
œœ˜ K˜
Kšœ
˜—Kšœ	œ
˜Kšœ
˜—K˜Kšœ
œœ
œ_˜€
K˜Kšœœœ
œ@˜oK˜Kš	œœ
	œ
œœ˜-K˜Kšœœ	œ
œT˜qK˜Kšœ
œ	œ
œ΅
˜Ψ
K˜šŸ	œœ œ˜BKš
˜Kšœœ
œ
˜Kš
œœ
œœœ
˜8Kšœ
˜—K˜š	Ÿœœœœ˜MKš
˜Kšœœ
œ
˜Kšœœ˜Kš
œœ
œœœ
˜8Kšœ
˜—K˜Kšœœœ
˜š
œ
œœ
œ	œ
œ
œ˜HJ™,—K˜šŸœœœœ
˜;Kš
˜Kšœœ
œ˜Kšœœ˜!š	œœ

œ
œ˜.Kšœœœ
˜-Kšœœ˜K˜Kšœ
˜—K˜!Kšœ
˜—K˜š
Ÿœœœœœ˜HKš
˜Kšœœ
œ˜Kšœœ˜šœœ
œ˜#Kšœœ
œ˜Kš
œ˜K˜Kš
œ˜Kšœ
˜—K˜K˜!Kšœ
˜—K˜šŸœœœœ
˜6Kš
˜Kšœœ
œ˜Kšœœ˜ š	œœ

œ
œ˜.Kšœœ˜%Kšœ
œ˜K˜Kšœ
˜—K˜!Kšœ
˜—K˜šŸœœœœ˜5Kš
˜šœœ˜Kšœ
œ
œ˜'Kšœ
˜—K˜Kšœ
˜—K˜šŸœœœœ
˜=Kš
˜Kšœœ˜šœœ
œ
˜Kšœ
œœœ˜:Kšœ
˜—Kšœ
˜—K˜Kšœ	œ	œ
œ
˜#K˜šŸœœ
œœœœ˜VKš
˜Kšœœœ˜AKšœ
˜—K˜šŸ	œœœœ˜-Kš
˜Kšœœ˜ šœ/œ˜AKš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kšœœœ	˜"Kš
œ˜—Kšœ
˜—K˜šŸœœ˜
Kš
˜Kšœœ˜šœœ
œ˜K˜Kšœ
˜—šœœ
œ˜K˜Kšœ
˜—šœœ
œ˜K˜K˜Kšœ
˜—K˜K˜K˜K˜K˜Kš
œL˜LKš
œM˜MKš
œ2˜2Kšœ
˜—K˜K˜K˜Kšœ
˜—…—T,rΤ