
<<PipalSisyphImpl.mesa>>
<<Copyright Ó 1985, 1986, 1987, 1988 by Xerox Corporation.  All rights reserved.>>
    <<Created by Sindhu and Serlet, November 27, 1985 9:11:39 pm PDT>>
    <<Pradeep Sindhu June 25, 1987 4:59:16 pm PDT>>
    <<Barth, October 15, 1986 10:25:34 am PDT>>
    <<Bertrand Serlet, May 13, 1988 3:29:20 pm PDT>>
    <<Jean-Marc Frailong December 12, 1987 5:41:02 pm PST>>
    <<Christian Jacobi, July 15, 1986 6:24:40 pm PDT>>
    <<Don Curry May 7, 1987 10:30:40 pm PDT>>

    DIRECTORY
        Convert, 
        Core, CoreClasses, CoreOps, CoreProperties,
        IO,
        Pipal, PipalConnect, PipalCore, PipalIO, PipalMos, PipalSinix, PipalSisyph,
        RefTab, Rope, RopeList,
        Scheme,
        TerminalIO;

PipalSisyphImpl: CEDAR PROGRAM                
IMPORTS Convert, CoreClasses, CoreOps, CoreProperties, IO, Pipal, PipalConnect, PipalCore, PipalIO, PipalMos, PipalSinix, RefTab, 
Rope, RopeList, Scheme, TerminalIO 
EXPORTS PipalSisyph
SHARES PipalSinix = 
BEGIN OPEN PipalSisyph; 
<<Types>>
    Context: TYPE = PipalSinix.Context;
    Environment: TYPE = Scheme.Environment;
        <<All variables have values which are Scheme data types except the ones which are CellTypes, Wire, Wires or ROPES>>
    Any: TYPE = Scheme.Any;
    CellType: TYPE = Core.CellType;
    Wire: TYPE = Core.Wire;
    Wires: TYPE = Core.Wires;
    WireSeq: TYPE = Core.WireSeq;
    ROPE: TYPE = Core.ROPE;
    ROPES: TYPE = LIST OF ROPE;
    Object: TYPE = Pipal.Object;
<<Constants and Variables>>
    defaultGlobalNames: PUBLIC ROPES _ LIST ["Vdd", "Gnd", "RosemaryLogicTime"];
    globalNames: PUBLIC ROPES _ defaultGlobalNames;

    instanceExpressionsProp: PUBLIC ATOM _ $SisyphInstanceExpressions;
    objectExpressionsProp: PUBLIC ATOM _ $SisyphObjectExpressions;

mode: PUBLIC PipalSinix.Mode _ NEW [PipalSinix.ModeRec _ [
decoration: PipalCore.schematicsDecoration,
extractMethod: Pipal.RegisterMethod["SchematicExtraction"],
connectMode: PipalConnect.schematicMode,
extractAnnotationProp: $SisyphExtractProc, -- for the sake of compatibility!
objectEqual: ObjectEqual,
postProcessFused: PostProcessFused
]];

    initialEnvironment: Environment = Scheme.NewEnvironmentStructure[];
<<Extraction Convenience>>
    Extract: PUBLIC PROC [name: ROPE, parameters: LIST OF IntegerParameter _ NIL] RETURNS [CellType] = {
        context: Context _ CreateContext[];
        object: Pipal.Object _ PipalIO.Fetch[name];
        IF object=NIL THEN {TerminalIO.PutF["*** Error: ES cannot find object '%g'.\n", IO.rope[name]]; ERROR};
        FOR list: LIST OF IntegerParameter _ parameters, list.rest WHILE list#NIL DO
            Define[context, list.first.variable, NEW [INT _ list.first.value]];
            ENDLOOP;
        RETURN [NARROW [PipalSinix.Extract[object, mode, context].result]];
        };
<<Context Handling Procedures>>
    <<This one in Scheme?>>
    IsDefinedTopLevel: PROC [env: Environment, variable: ATOM] RETURNS [BOOL] = {
        values: RefTab.Ref _ NARROW [env.values];
        RETURN [RefTab.Fetch[values, variable].found];
        };

    InternalDefine: PROC [env: Environment, variable: ATOM, value: Any] = {
        IF IsDefinedTopLevel[env, variable] 
            THEN SIGNAL ContextProblem["Variable set twice", variable] 
            ELSE Scheme.DefineVariable[variable, value, env];
        };

    InternalSet: PROC [env: Environment, variable: ATOM, value: Any] = {
        IF NOT IsDefinedTopLevel[env, variable] 
            THEN SIGNAL ContextProblem["Undefined variable", variable] 
            ELSE [] _ Scheme.SetVariableValue[variable, value, env];
        };

    InternalGet: PROC [env: Environment, variable: ATOM] RETURNS [value: Any] = {
        value _ Scheme.LookupVariableValue[variable, env];
        };

    InternalEval: PROC [env: Environment, expr: Core.ROPE] RETURNS [value: Any] = {
        value _ Scheme.Eval[Scheme.ReadRope[expr, TRUE], env];
        };

    InternalDefineEval: PROC [env: Environment, variable: ATOM, expr: Core.ROPE] = {
        InternalDefine[env, variable, InternalEval[env, expr]];
        };

    InternalSetEval: PROC [env: Environment, variable: ATOM, expr: Core.ROPE] = {
        InternalSet[env, variable, InternalEval[env, expr]];
        };

    <<Checks that a PipalSinix context is of the right form, i.e. a 2-level environement:  >>
        <<- the parent is initialEnvironment, always invariant.>>
        <<- the current environment contains the few current variables.>>
    Narrow: PROC [context: Context] RETURNS [env: Environment] = {
        env _ NARROW [context];
        IF env.parent=NIL OR env.names#NIL OR env.values=NIL THEN SIGNAL PipalSinix.InternalBug[];
        IF env.parent#initialEnvironment THEN SIGNAL PipalSinix.InternalBug[];
        };

    SchemeToCedar: PROC [value: Any] RETURNS [REF] = {
        RETURN [WITH value SELECT FROM
            string: Scheme.String    => Scheme.RopeFromString[string],
            ENDCASE        => value];
        };

    SchemeToCedarInt: PROC [value: Any] RETURNS [int: INT] = {
        WITH SchemeToCedar[value] SELECT FROM
            refInt: REF INT    => int _ refInt^;
            refNat: REF NAT    => int _ refNat^;
            ENDCASE        => SIGNAL PipalSinix.CallerBug[];
        };

    CedarToScheme: PROC [value: REF] RETURNS [Any] = {
        RETURN [WITH value SELECT FROM
            rope: ROPE    => Scheme.StringFromRope[rope],
            ENDCASE    => value];
        };

    CreateContext: PUBLIC PROC RETURNS [context: Context] = {
        env: Environment _ NEW [Scheme.EnvironmentRep _ [
            parent: initialEnvironment, names: NIL, values: RefTab.Create[], mark: 100,
            id: Scheme.StringFromRope["PipalSisyph"]
            ]];
        context _ env;
        };

NewAssignmentContext: PROC [context: Context, assignments: LIST OF ParsedRope] RETURNS [Context] = {
env: Environment _ Narrow[context];
new: Environment  _ NEW [Scheme.EnvironmentRep _ [parent: env.parent, names: NIL, values: RefTab.Copy[NARROW [env.values]]]];
FOR list: LIST OF ParsedRope _ assignments, list.rest WHILE list#NIL DO
InternalSet[new, list.first.variable, InternalEval[env, list.first.expr]];
ENDLOOP;
RETURN [new];
};

NewDeclarationContext: PROC [context: Context, declarations: LIST OF ParsedRope] RETURNS [Context] = {
env: Environment _ Narrow[context];
new: Environment  _ NEW [Scheme.EnvironmentRep _ [parent: env.parent, names: NIL, values: RefTab.Create[]]];
FOR list: LIST OF ParsedRope _ declarations, list.rest WHILE list#NIL DO
variable: ATOM _ list.first.variable;
InternalDefine[new, variable, IF IsDefinedTopLevel[env, variable] THEN InternalGet[env, variable] ELSE InternalEval[env.parent, 
list.first.expr]];
ENDLOOP;
RETURN [new];
};

EvalProperties: PROC [context: Context, object: Object, properties: LIST OF ParsedRope, others: ROPES, props: Core.Properties] 
RETURNS [Core.Properties] = {
FOR list: LIST OF ParsedRope _ properties, list.rest WHILE list#NIL DO
key: ATOM _ list.first.variable;
value: REF _ Eval[context, list.first.expr];
oldValue: REF _ CoreProperties.GetProp[props, key];
IF oldValue#NIL AND oldValue#value THEN SIGNAL PipalSinix.FusionPropMismatch[object, key, oldValue, value];
props _ CoreProperties.PutProp[props, key, value];
ENDLOOP;
FOR list: ROPES _ others, list.rest WHILE list#NIL DO
props _ LayoutProcessName[object, list.first, props];
ENDLOOP;
RETURN [props];
};

    Define: PUBLIC PROC [context: Context, variable: ATOM, value: REF] = {
        InternalDefine[Narrow[context], variable, CedarToScheme[value]];
        };

    Set: PUBLIC PROC [context: Context, variable: ATOM, value: REF] = {
        InternalSet[Narrow[context], variable, CedarToScheme[value]];
        };

    Get: PUBLIC PROC [context: Context, variable: ATOM] RETURNS [value: REF] = {
        value _ SchemeToCedar[InternalGet[Narrow[context], variable]];
        };

    GetInt: PUBLIC PROC [context: Context, variable: ATOM] RETURNS [value: INT] = {
        value _ SchemeToCedarInt[InternalGet[Narrow[context], variable]];
    };

    GetAtom: PUBLIC PROC [context: Context, variable: ATOM] RETURNS [value: ATOM] = {
    value _ NARROW [Get[context, variable]];
    };

    GetRope: PUBLIC PROC [context: Context, variable: ATOM] RETURNS [value: Core.ROPE] = {
        value _ NARROW [Get[context, variable]];
        };

    Eval: PUBLIC PROC [context: Context, expr: Core.ROPE] RETURNS [value: REF] = {
        <<ENABLE ANY => SIGNAL InterpreterProblem[context, expr, NIL];>>
        value _ SchemeToCedar[InternalEval[Narrow[context], expr]];
        };

    DefineEval: PUBLIC PROC [context: Context, variable: ATOM, expr: Core.ROPE] = {
        Define[context, variable, Eval[context, expr]];
        };

    SetEval: PUBLIC PROC [context: Context, variable: ATOM, expr: Core.ROPE] = {
        Set[context, variable, Eval[context, expr]];
        };
<<Exceptions>>
    ContextProblem: PUBLIC SIGNAL [message: Core.ROPE, variable: ATOM] = CODE;

    GlobalNonAtomic: PUBLIC SIGNAL [object: Object, name: ROPE, wire: Wire] = CODE;

    InterpreterProblem: PUBLIC SIGNAL [context: Context, expr, errorRope: ROPE] = CODE;
<<Parsing >>
    ParseRope: PROC [rope: ROPE] RETURNS [tokenKind: IO.TokenKind, token, rest: ROPE] = {
        ENABLE {
            IO.Error => GOTO Error;
            IO.EndOfStream => GOTO EOF;
            };
        stream: IO.STREAM _ IO.RIS[rope];
        charsSkipped1: INT _ IO.SkipWhitespace[stream];
        charsSkipped2: INT;
        [tokenKind, token, charsSkipped2] _ IO.GetCedarTokenRope[stream];
        rest _ Rope.Substr[rope, charsSkipped1+charsSkipped2+Rope.Length[token]];
        EXITS 
            Error => RETURN [tokenERROR, NIL, NIL];
            EOF => RETURN [tokenEOF, NIL, NIL];
        };

    ParseSatellite: PUBLIC PROC [satellite: ROPE] RETURNS [variable: ATOM _ NIL, char: CHAR, expr: ROPE] = {
        tokenKind1, tokenKind2: IO.TokenKind; token1, token2: ROPE;
        [tokenKind1, token1, expr] _ ParseRope[satellite];
        IF tokenKind1#tokenID THEN RETURN [NIL, '!, satellite];
        [tokenKind2, token2, expr] _ ParseRope[expr];
        IF tokenKind2#tokenSINGLE THEN RETURN [NIL, '!, satellite];
        char _ Rope.Fetch[token2];
        IF char#'~ AND char#'_ AND char#': THEN RETURN [NIL, '!, satellite];
        variable _ Convert.AtomFromRope[token1];
        };

    ParseSatellites: PUBLIC PROC [satellites: ROPES] RETURNS [declarations, assignments, properties: LIST OF ParsedRope _ NIL, others: 
    ROPES _ NIL] = {
        WHILE satellites#NIL DO
            variable: ATOM; char: CHAR; expr: ROPE;
            [variable, char, expr] _ ParseSatellite[satellites.first];
            IF variable=NIL 
                THEN others _ CONS [satellites.first, others] ELSE SELECT char FROM 
                    '~    => declarations _ CONS [[variable, expr], declarations];
                    '_    => assignments _ CONS [[variable, expr], assignments];
                    ':    => properties _ CONS [[variable, expr], properties];
                    ENDCASE    => SIGNAL PipalSinix.InternalBug[];
            satellites _ satellites.rest;
            ENDLOOP;
        };

<<Context Equality and Caching>>
    EqualRopes: PUBLIC PROC [ropes1, ropes2: ROPES] RETURNS [BOOL] = {
        FOR r1: ROPES _ ropes1, r1.rest WHILE r1#NIL DO
            IF NOT RopeList.Memb[ropes2, r1.first] THEN RETURN [FALSE];
            ENDLOOP; 
        FOR r2: ROPES _ ropes2, r2.rest WHILE r2#NIL DO
            IF NOT RopeList.Memb[ropes1, r2.first] THEN RETURN [FALSE];
            ENDLOOP; 
        RETURN [TRUE];
        };

    EqualValues: PROC [value1, value2: REF] RETURNS [BOOL] = {
        <<Added code to handle the special case of ROPE as well as ROPES>>
        IF value1=value2 THEN RETURN [TRUE];
        WITH value1 SELECT FROM 
            rr1: ROPES    => WITH value2 SELECT FROM
                rr2: ROPES    => RETURN [EqualRopes[rr1, rr2]];
                ENDCASE    => RETURN [FALSE];
            r1: ROPE    => WITH value2 SELECT FROM
                r2: ROPE    => RETURN [Rope.Equal[r1, r2]];
                ENDCASE    => RETURN [FALSE];
            ri1: REF INT    => WITH value2 SELECT FROM
                ri2: REF INT    => RETURN [ri1^=ri2^];
                ri2: REF NAT    => RETURN [ri1^=ri2^];
                ENDCASE    => RETURN [FALSE];
            ri1: REF NAT    => WITH value2 SELECT FROM
                ri2: REF INT    => RETURN [ri1^=ri2^];
                ri2: REF NAT    => RETURN [ri1^=ri2^];
                ENDCASE    => RETURN [FALSE];
            ENDCASE    => RETURN [FALSE];
        };

    <<This one depends quite heavily on Scheme ...>>
    <<Returns TRUE iff a is a subset of b>>
    IsSubset: PROC [a, b: RefTab.Ref] RETURNS [BOOL] = {
        CheckAbsentInb: RefTab.EachPairAction = {
            found: BOOL; bVal: RefTab.Val;
            pair1, pair2: Scheme.Pair;
            <<It is a potential parameter. Check if its there in the context and equal>>
            [found, bVal] _ RefTab.Fetch[b, key];
            IF NOT found THEN RETURN [TRUE];
            IF bVal=val THEN RETURN [FALSE];
            pair1 _ NARROW [bVal]; pair2 _ NARROW [val];
            IF pair1.car#pair2.car THEN SIGNAL PipalSinix.InternalBug[];
        quit _ NOT EqualValues[pair1.cdr, pair2.cdr];
            };
        RETURN [NOT RefTab.Pairs[a, CheckAbsentInb]];
        };

    ObjectEqual: PROC [object: Object, context1, context2: Context] RETURNS [BOOL] = {
        env1: Environment _ Narrow [context1];
        env2: Environment _ Narrow [context2];
        table1: RefTab.Ref _ NARROW [env1.values];
        table2: RefTab.Ref _ NARROW [env2.values];
        IF env1.parent#env2.parent THEN RETURN [FALSE];
        RETURN [IsSubset[table1, table2] AND IsSubset[table2, table1]];
        };
<<ExtractProcs>>
OrNames: PROC [object: Object, name1, name2: ROPE] RETURNS [name: ROPE _ NIL] = {
IF name1=NIL THEN RETURN [name2];
IF name2=NIL THEN RETURN [name1];
IF Rope.Equal[name1, name2] THEN RETURN [name1];
SIGNAL PipalSinix.FusionPropMismatch[object, CoreOps.nameProp, name1, name2];
};

LayoutProcessName: PROC [object: Object, name: ROPE, props: Core.Properties] RETURNS [Core.Properties] = {
name _ OrNames[object, name, NARROW [CoreProperties.GetProp[props, CoreOps.nameProp]]];
RETURN [CoreProperties.PutProp[props, CoreOps.nameProp, name]];
};

ExtractSats: PROC [object: Object, context: Context, satellites: ROPES, instance: BOOL] RETURNS [result: REF, props: 
Core.Properties] = {
declarations, assignments, properties: LIST OF ParsedRope; others: ROPES;
[declarations, assignments, properties, others] _ ParseSatellites[satellites];
IF instance THEN {
IF declarations#NIL THEN SIGNAL PipalSinix.CallerBug[];
IF assignments#NIL THEN context _ NewAssignmentContext[context, assignments];
[result, props] _ PipalSinix.Extract[object, mode, context];
IF result=NIL THEN RETURN; 
WITH result SELECT FROM
subWire: Wire             => {
wire: Wire _ CoreOps.CopyWire[subWire];
PipalCore.PutPort[mode.decoration, wire, object];
wire.properties _ EvalProperties[context, object, properties, others, wire.properties];
result _ wire;
};
subWires: Wires         => SIGNAL PipalSinix.CallerBug[]; -- what to do with that name!
subCellType: CellType    => props _ EvalProperties[context, object, properties, others, props];
ENDCASE                    => SIGNAL PipalSinix.InternalBug[];
} ELSE {
IF assignments#NIL THEN SIGNAL PipalSinix.CallerBug[];
IF declarations#NIL THEN context _ NewDeclarationContext[context, assignments];
[result, props] _ PipalSinix.NonCachingExtract[object, mode, context];
IF result=NIL THEN RETURN; 
WITH result SELECT FROM
subWire: Wire             => subWire.properties _ EvalProperties[context, object, properties, others, subWire.properties];
subWires: Wires         => SIGNAL PipalSinix.CallerBug[]; -- what to do with that name!
subCellType: CellType    =>
subCellType.properties _ EvalProperties[context, object, properties, others, subCellType.properties];
ENDCASE                    => SIGNAL PipalSinix.InternalBug[];

};
};

ExtractAnnotation: PipalSinix.ExtractProc = {
annotation: Pipal.Annotation = NARROW [object];
SELECT annotation.key FROM
mode.extractAnnotationProp    => {
atom: ATOM = NARROW [annotation.value];
proc: PipalSinix.ExtractProc _ PipalSinix.FetchExtractProc[atom];
IF proc=NIL THEN {
TerminalIO.PutF["*** ExtractProc $%g not registered.  You must run the program defining it.\n", IO.atom[atom]]; SIGNAL 
PipalSinix.CallerBug[];
};
[result, props] _ proc[annotation.child, mode, context];
};
Pipal.nameProp    => {
name: ROPE _ NARROW [annotation.value];
[result, props] _ PipalSinix.NonCachingExtract[annotation.child, mode, context];
IF result=NIL THEN RETURN; 
WITH result SELECT FROM
subWire: Wire             =>
subWire.properties _ LayoutProcessName[object, name, subWire.properties];
subWires: Wires         => SIGNAL PipalSinix.CallerBug[]; -- what to do with that name!
subCellType: CellType    =>
subCellType.properties _ LayoutProcessName[object, name, subCellType.properties];
ENDCASE                    => SIGNAL PipalSinix.InternalBug[];
};
instanceExpressionsProp    => [result, props] _ ExtractSats[annotation.child, context, NARROW [annotation.value], TRUE];
objectExpressionsProp        => [result, props] _ ExtractSats[annotation.child, context, NARROW [annotation.value], FALSE];
PipalMos.indirectProp        => SIGNAL PipalSinix.CallerBug[];
ENDCASE    => [result, props] _ PipalSinix.ExtractConnectized[object, mode, context];
};

ExtractStar: PipalSinix.ExtractProc = {
star: PipalMos.Star = NARROW [object];
[result, props] _ ExtractSats[star.master, context, PipalMos.GetNonItalicRopes[star], NOT star.overlayStar];
};

ExtractSchematicIcon: PipalSinix.ExtractProc = {
icon: PipalMos.SchematicIcon _ NARROW [object];
iconCT: CellType _ NARROW [PipalSinix.Extract[icon.child, mode, context].result];
result _ IF icon.code 
THEN Eval[context, icon.expression] 
ELSE Extract[icon.expression];
SELECT icon.type FROM
cell    => {
cellType: CellType;
IF result=NIL THEN SIGNAL PipalSinix.CallerBug[];
cellType _ PipalSinix.CreateIcon[NARROW [result]];
PipalCore.PutObject[mode.decoration, cellType, object];
<<Check public>>
IF NOT CheckAndDecorate[object, iconCT.public, cellType.public] THEN {
TerminalIO.PutF["*** Error: icon public and schematic public do NOT conform\n"];
TerminalIO.PutF["Icon public is:"];
CoreOps.PrintWire[wire: iconCT.public, out: TerminalIO.TOS[], level: LAST [NAT]];
TerminalIO.PutF["\nSchematic public is:"];
CoreOps.PrintWire[wire: cellType.public, out: TerminalIO.TOS[], level: LAST [NAT]];
TerminalIO.PutF["\n"];
ERROR
};
result _ cellType;
};
wire, unnamedWire    => {
FlushName: CoreOps.EachWireProc = {[] _ CoreOps.SetShortWireName[wire, NIL]};
resultWire: WireSeq;
IF result=NIL THEN {
result _ resultWire _ iconCT.public; 
IF icon.type = unnamedWire THEN [] _ CoreOps.VisitWireSeq[resultWire, FlushName];
RETURN;
};
WITH result SELECT FROM
wires: Wires        => result _ resultWire _ CoreOps.CreateWire[wires]; 
ww: Wire            => {result _ ww; resultWire _ CoreOps.CreateWire[LIST [ww]]};
cellType: CellType    => {
IF props#NIL THEN ERROR;
result _ resultWire _ CoreOps.CopyWire[cellType.public]; 
};
ENDCASE            => ERROR;
<<special case>>
IF NOT CheckAndDecorate[object, iconCT.public, resultWire] THEN {
TerminalIO.PutF["*** Error: icon wire and result wire icon don't conform\n"];
TerminalIO.PutF["Icon wire is:"];
CoreOps.PrintWire[wire: iconCT.public, out: TerminalIO.TOS[], level: LAST [NAT]];
TerminalIO.PutF["\nResult wire is:"];
CoreOps.PrintWire[wire: resultWire, out: TerminalIO.TOS[], level: LAST [NAT]];
TerminalIO.PutF["\n"];
ERROR
};
IF icon.type = unnamedWire THEN [] _ CoreOps.VisitWireSeq[resultWire, FlushName];
};
ENDCASE    => SIGNAL PipalSinix.CallerBug[];
};

ExtractSchematicSequence: PipalSinix.ExtractProc = {
seq: PipalMos.SchematicSequence _ NARROW [object];
value: REF INT _ NARROW [Eval[context, seq.repetition]];
count: NAT _ value^;
wholeCT, baseCT, sequence: CellType; 
internal, baseActual, basePublic: WireSeq;
baseInst: CoreClasses.RecordCellType;
sequenceWires, flatSequenceWires: Wires _ NIL;

[result, props] _ PipalSinix.Extract[seq.child, mode, context];
IF props#NIL THEN ERROR;
wholeCT _ NARROW [result];
baseInst _ NARROW [wholeCT.data];
internal _ baseInst.internal;
<<There should be only one subcell>>
IF baseInst.size#1 THEN {
TerminalIO.PutF["*** ExtractSchematicSequence: Sequence should contain one and only one subcell.\n"];
ERROR};
baseCT _ baseInst[0].type; baseActual _ baseInst[0].actual; basePublic _ baseCT.public;
<<we check that there is no internal only>>
FOR i: NAT IN [0 .. internal.size) DO
wire: Wire = internal[i];
name: ROPE _ CoreOps.GetShortWireName[wire];
IF name=NIL THEN name _ "some wire";
IF NOT CoreOps.RecursiveMember[baseActual, wire] THEN {
TerminalIO.PutF["*** ExtractSchematicSequence: %g is not connected to subcell.\n", IO.rope[name]];
ERROR}; 
IF NOT CoreOps.RecursiveMember[wholeCT.public, wire] THEN {
TerminalIO.PutF["*** ExtractSchematicSequence: %g is not public.\n", IO.rope[name]];
ERROR}; 
ENDLOOP;
<<We compute which wires are going to be sequenced>>
FOR i: NAT IN [0 .. basePublic.size) DO
IF CoreProperties.GetWireProp[baseActual[i], $Sequence]#NIL 
THEN sequenceWires _ CONS [basePublic[i], sequenceWires];
IF CoreProperties.GetWireProp[baseActual[i], $FlatSequence]#NIL 
THEN flatSequenceWires _ CONS [basePublic[i], flatSequenceWires];
ENDLOOP;
<<We create the sequence>>
sequence _ CoreClasses.CreateSequence[
args: NEW [CoreClasses.SequenceCellTypeRec _ [
base: baseCT, count: count, 
sequence: FindPorts[basePublic, sequenceWires], 
flatSequence: FindPorts[basePublic, flatSequenceWires]
]],
name: CoreOps.GetCellTypeName[wholeCT], props: props
];
<<Attention here: we copy only a few selected properties, because it is bad to have designers rely on the way the sequence is 
obtained (extracting the whole thing, thus gathering properties).  Moreover, if we copy all, things like the Sequence information 
will crap up, thus messing the level above (e.g. if it is a sequence itself).>>
FOR i: NAT IN [0..sequence.public.size) DO
iconWire: Wire = CoreClasses.CorrespondingActual[baseInst[0], basePublic[i]];
PipalCore.PutPort[PipalCore.schematicsDecoration, sequence.public[i], iconWire];
PipalCore.PutGeometry[PipalCore.schematicsDecoration, sequence.public[i], PipalCore.GetGeometry[PipalCore.schematicsDecoration, 
iconWire]];
ENDLOOP;
<<The object decoration!>>
PipalCore.PutObject[mode.decoration, sequence, object];
result _ sequence;
};

FindPorts: PROC [basePublic: WireSeq, wires: Wires] RETURNS [set: CoreClasses.SequenceSet] = {
nats: LIST OF NAT _ NIL;
size: NAT _ 0;
WHILE wires#NIL DO
FOR w: NAT IN [0 .. basePublic.size) DO
sequenceName: ROPE _ CoreOps.GetShortWireName[wires.first]; 
IF wires.first=basePublic[w] OR (sequenceName#NIL AND Rope.Equal[sequenceName, CoreOps.GetShortWireName[basePublic[w]]]) THEN {
nats _ CONS [w, nats]; size _ size + 1;
EXIT};
REPEAT FINISHED => ERROR;
ENDLOOP; 
wires _ wires.rest;
ENDLOOP;
set _ NEW [CoreClasses.SequenceSetRec[size]];
FOR i: INT IN [0 .. size) DO set[i] _ nats.first; nats _ nats.rest ENDLOOP;
};
<<Utilities for the implementation>>
    CheckAndDecorate: PROC [object: Object, drawnPublic, resultPublic: WireSeq] RETURNS [ok: BOOL _ TRUE] = {
        resultToDrawn: RefTab.Ref _ RefTab.Create[]; -- associates resultPublic to drawnPublic
        <<Construct the association by searching in resultPublic for every name found in drawnPublic>>
    FOR i: NAT IN [0 .. drawnPublic.size) DO
        EachResultWire: CoreOps.EachWireProc = {
            resultName: ROPE _ CoreOps.GetShortWireName[wire];
            IF NOT Rope.Equal[resultName, drawnName] THEN RETURN;
            IF wire=resultWire THEN RETURN;
            IF resultWire#NIL THEN {TerminalIO.PutF["*** Drawn Icon has a wire %g whose name appears more than once in the schematic\n", 
            IO.rope[drawnName]]; quit _ TRUE; ok _ FALSE; RETURN};
            resultWire _ wire;
            };
    drawnWire: Wire _ drawnPublic[i];
        drawnName: ROPE _ CoreOps.GetShortWireName[drawnWire];
        resultWire: Wire _ NIL;
    IF drawnName=NIL THEN {TerminalIO.PutF["*** Drawn Icon has an unnamed wire\n"]; ok _ FALSE; LOOP};
        IF CoreOps.VisitWire[resultPublic, EachResultWire] THEN LOOP;
        IF resultWire=NIL THEN {TerminalIO.PutF["*** Drawn Icon has wire %g that doesn't correspond to any wire in the schematic\n", 
        IO.rope[drawnName]]; ok _ FALSE; LOOP};
        <<We decorate the resultWire with the pins of drawnWire>>
        PipalCore.PutPort[mode.decoration, resultWire, PipalCore.GetPort[mode.decoration, drawnWire]];
        [] _ RefTab.Store[resultToDrawn, resultWire, drawnWire];
    ENDLOOP;
        <<Ensure that each resultPublic corresponds to some iconic Wire (apart may be from the wires in globalNames).  Warning only for 
        those.>>
    FOR i: NAT IN [0 .. resultPublic.size) DO
    resultWire: Wire _ resultPublic[i];
        resultName: ROPE _ CoreOps.GetShortWireName[resultWire];
        drawnWire: Wire _ NARROW [RefTab.Fetch[resultToDrawn, resultWire].val];
    IF resultName=NIL THEN LOOP;
    IF drawnWire#NIL THEN LOOP;
    IF RopeList.Memb[globalNames, resultName] THEN LOOP;
    TerminalIO.PutF["*** Warning: schematic has wire %g that corresponds to no wire in the drawn Icon\n", IO.rope[resultName]]; 
    ENDLOOP;
        };

ProcessGlobalName: PROC [object: Object, fused: RefTab.Ref, instances: LIST OF CoreClasses.CellInstance, name: ROPE] = {
global: Wire;
globals: Wires;
InsertGlobal: PROC [wire: Wire] = {
IF wire.size#0 THEN SIGNAL GlobalNonAtomic[object, name, wire];
IF NOT CoreOps.Member[globals, wire] THEN globals _ CONS [wire, globals];
};
FindGlobals: CoreOps.EachWirePairProc = {
act: Wire _ PipalSinix.RootWire[fused, actualWire];
actualName: ROPE = CoreOps.GetShortWireName[act];
IF NOT Rope.Equal[CoreOps.GetShortWireName[publicWire], name] THEN RETURN;
IF actualName=NIL OR Rope.Equal[actualName, name] THEN InsertGlobal[act];
};
EachWire: PROC [wire: Core.Wire] = {
IF Rope.Equal[CoreOps.GetShortWireName[wire], name] THEN InsertGlobal[wire];
};
FOR list: LIST OF CoreClasses.CellInstance _ instances, list.rest WHILE list#NIL DO
[] _ CoreOps.VisitBindingSeq[list.first.actual, list.first.type.public, FindGlobals];
ENDLOOP;
[] _ PipalSinix.EnumerateRoots[fused, EachWire];
IF globals=NIL THEN RETURN;
global _ CoreOps.SetShortWireName[globals.first, name];
CoreProperties.PutWireProp[global, $Public, $Public];
globals _ globals.rest;
WHILE globals#NIL DO
global _ PipalSinix.StructuredFusion[mode, object, fused, global, globals.first];
globals _ globals.rest;
ENDLOOP;
};

PostProcessFused: PipalSinix.PostProcessProc = {
FOR names: ROPES _ globalNames, names.rest WHILE names#NIL DO
ProcessGlobalName[object, fused, instances, names.first];
ENDLOOP;
PipalSinix.SchematicsFusionByName[mode, object, context, fused, instances];
};

<<Scheme Functions>>
    ToCedar: PROC [primitive: Scheme.Primitive, arg1, arg2, arg3: Any, pl: Scheme.ProperList] RETURNS [result: Any] = {
        result _ SchemeToCedar[arg1];
        };

    CreateWire: PROC [primitive: Scheme.Primitive, arg1, arg2, arg3: Any, pl: Scheme.ProperList] RETURNS [result: Any] = {
        result _ CoreOps.CreateWire[];
        };

    CreateTransistor: PROC [primitive: Scheme.Primitive, arg1, arg2, arg3: Any, pl: Scheme.ProperList] RETURNS [result: Any] = {
        result _ CoreClasses.CreateTransistor[
            SELECT arg1 FROM $ne => nE, $pe => pE, $nd => nD, ENDCASE => ERROR,
            SchemeToCedarInt[arg2],
            SchemeToCedarInt[arg3]
            ];
        };


<<Module Initialization>>
    Pipal.PutClassMethod[Pipal.annotationClass, mode.extractMethod, NEW [PipalSinix.ExtractProc _ ExtractAnnotation]];
    Pipal.PutClassMethod[PipalMos.starClass, mode.extractMethod, NEW [PipalSinix.ExtractProc _ ExtractStar]];
    Pipal.PutClassMethod[PipalMos.schematicIconClass, mode.extractMethod, NEW [PipalSinix.ExtractProc _ ExtractSchematicIcon]];
    Pipal.PutClassMethod[PipalMos.schematicSequenceClass, mode.extractMethod, NEW [PipalSinix.ExtractProc _ ExtractSchematicSequence]];

    PipalSinix.schematicsMode _ mode;

    Scheme.DefinePrimitive["cedar", 1, FALSE, ToCedar, "converts a Scheme argument to a Cedar argument", initialEnvironment];
    Scheme.DefinePrimitive["createwire", 0, FALSE, CreateWire, "creates a Core wire", initialEnvironment];
    Scheme.DefinePrimitive["createtransistor", 3, FALSE, CreateTransistor, "creates a Core transistor", initialEnvironment];

END.

    <<>>