Return to fay.p CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / pascal / tstpx / src

Annotation of 43BSDTahoe/ucb/pascal/tstpx/src/fay.p, revision 1.1

1.1     ! root        1: { AN OPEN CHALLENGE TO ALL PASCAL COMPILERS:  Compile this program
        !             2:    correctly and produce the correct output. 
        !             3: 
        !             4:   Send responses, counter-challenges, etc., to:
        !             5:    Tom Pennello
        !             6:    Computer and Information Sciences
        !             7:    University of California
        !             8:    Santa Cruz, CA.  95064
        !             9: }
        !            10: 
        !            11: program p(output);
        !            12: type integer = -32767..32768; node = 0..4500;
        !            13: var Debug: boolean;
        !            14: 
        !            15: procedure EachUSCC( { of relation R }
        !            16:       { Pass in an iterator to generate the nodes to be searched,
        !            17:         the relation on the nodes, a procedure to do information
        !            18:         propagation when V R W is discovered, a procedure
        !            19:         to take each SCC found, and a procedure to yield each
        !            20:         node in the graph. 
        !            21:         We require that the nodes be of a scalar type so that
        !            22:         an array may be indexed by them.  Also passed in is the
        !            23:         upper bound of the node type. }
        !            24:       procedure EachUnode(procedure P(T:node)); { Yields each node in graph }
        !            25:       procedure EachUnodeUtoUsearch(procedure SearchU(V:node));
        !            26:       procedure R(V:node; procedure DoUsuccessor(W:node));
        !            27:       procedure Propagate(V,W:node); { called when V R W is discovered }
        !            28:       procedure TakeUSCC(Root:node; procedure Each(procedure P(T:node)));
        !            29:       LastUnode: integer
        !            30:       ); 
        !            31: 
        !            32:    type
        !            33:       A = array[node] of integer; { range 0..Infinity (below) }
        !            34:    var N: ^A;  SP: integer;
        !            35:       Stack: array[node {1..LastUnode}] of node;
        !            36:       Infinity: integer; { LastUnode+1 }
        !            37: 
        !            38:    procedure P(T:node); begin N^[T] := 0; end;
        !            39:    
        !            40:    procedure Search(V:node);
        !            41:       var I,T:integer;
        !            42:       procedure DoUsuccessor(W:node);
        !            43:          begin
        !            44:          Search(W);
        !            45:          if N^[W] < N^[V] then N^[V] := N^[W];
        !            46:          Propagate(V,W);
        !            47:          end;
        !            48: 
        !            49:       { EachUmember is yielded by EachUSCC when an SCC has been found. }
        !            50:       procedure EachUmember(procedure P(TU:node));
        !            51:          var I:integer;
        !            52:          begin { yield each member of current SCC }
        !            53:          for I := SP downto T do P(Stack[I]);
        !            54:          end;
        !            55: 
        !            56:       procedure YieldUSCC; 
        !            57:          begin
        !            58: if Debug then writeln('YieldUSCC passes',V,' to TakeUSCC');
        !            59:          TakeUSCC(V,EachUmember);
        !            60:          end; 
        !            61: 
        !            62:       begin
        !            63:       if N^[V] = 0 then begin { stack the node }
        !            64: if Debug then writeln('stacking ',V);
        !            65:          SP := SP+1;
        !            66:          Stack[SP] := V;  N^[V] := SP;
        !            67: if Debug then writeln('Doing successors of ',V);
        !            68:          R(V,DoUsuccessor);
        !            69: if Debug then writeln('Now checking if ',V,' is an SCC root');
        !            70:          if V = Stack[N^[V]] then begin { V is root of an SCC }
        !            71:             T := N^[V];
        !            72: if Debug then writeln(V,' is an SCC root; SP=',SP,' T=',T);
        !            73:             for I := SP downto T do N^[Stack[I]] := Infinity;
        !            74:             if SP <> T then begin
        !            75: if Debug then writeln('Yield SCC should pass ',V,' out to TakeUSCC');
        !            76:                YieldUSCC;
        !            77:                end;
        !            78:             SP := T-1;
        !            79:             end;
        !            80:          end;
        !            81:       end; 
        !            82:    begin
        !            83:    Infinity := LastUnode+1;
        !            84:    new(N); EachUnode(P);
        !            85:    SP := 0;
        !            86:    EachUnodeUtoUsearch(Search);
        !            87:    dispose(N);
        !            88:    end;
        !            89: 
        !            90: procedure Outer; { needed to produce bug in Berkeley Pascal compiler }
        !            91:    procedure q;
        !            92:       procedure EachUnodeUtoUsearch(procedure Search(T:node));
        !            93:          begin 
        !            94:          Search(1);
        !            95:          end;
        !            96:       procedure EachUnode(procedure P(T:node));
        !            97:          begin P(1); P(2);
        !            98:          end;
        !            99:       procedure R(V:node; procedure P(W:node));
        !           100:          begin 
        !           101:          { Defines graph with edges 1->2 and 2->1 }
        !           102:          { Thus, the graph contains one SCC:  [1,2] }
        !           103:          case V of
        !           104:             1: P(2); 
        !           105:             2: P(1);
        !           106:             end;
        !           107:          end;
        !           108:       procedure Propagate(V,W:node); begin end;
        !           109:       procedure TakeUSCC(Root:node; procedure Each(procedure P(T:node)));
        !           110:          procedure P(T:node); begin write(T); end;
        !           111:          begin
        !           112:          writeln('TakeUSCC receives V=',Root,' from YieldUSCC');
        !           113:          writeln('The SCC''s constituents are:');
        !           114:          Each(P); writeln;
        !           115:          end;
        !           116:       begin
        !           117:       EachUSCC(EachUnode,EachUnodeUtoUsearch,R,Propagate,TakeUSCC,2);
        !           118:       end;
        !           119: 
        !           120: procedure Doit;
        !           121:    begin
        !           122:    q;
        !           123:    end;
        !           124: 
        !           125: begin
        !           126: Doit;
        !           127: end;
        !           128: 
        !           129: begin
        !           130: Debug := true;
        !           131: Outer;
        !           132: end.
        !           133: 
        !           134: {----------------------------------------------------------------
        !           135:   An alternate version of this program, written in a language 
        !           136:   supporting iterators, iterators as parameters, iterators
        !           137:   as yielded results of iterators, and the ability to yield more
        !           138:   than one thing, might be as follows:
        !           139:  ----------------------------------------------------------------
        !           140: 
        !           141: iterator EachUSCC(
        !           142:    iterator EachUnode:node;
        !           143:    iterator EachUnodeUtoUsearch:node;
        !           144:    iterator R(V:node):node;
        !           145:    procedure Propagate(V,W:node);
        !           146:    LastUnode:node
        !           147:                  ):
        !           148:    (Root:node; iterator EachUnodeUinUSCC:node);
        !           149:    # EachUSCC yields two results:  the Root of the SCC,
        !           150:    # and an iterator that yields each member of that SCC.
        !           151: 
        !           152:    type A = aray[node] of integer;
        !           153:    var N: ^A; SP: integer;
        !           154:        Stack: array[node] of node;
        !           155:        Infinity: integer;
        !           156:  
        !           157:    procedure Search(V);
        !           158:       var T: integer;
        !           159:       iterator EachUmember:node;
        !           160:          begin
        !           161:          for I := SP downto T do P(Stack[I]);
        !           162:          end;
        !           163:       begin
        !           164:       if N^[V] = 0 then begin
        !           165:          SP := SP+1;  Stack[SP] := V;  N^[V] := SP;
        !           166:          for W in R(V) do begin   # Search successors of V.
        !           167:             Search(W);
        !           168:             if N^[W] < N^[V] then N^[V] := N^[W];
        !           169:             Propagate(V,W);
        !           170:             end;
        !           171:          if V = Stack[N^[V]] then begin 
        !           172:             T := N^[V];           # V is an SCC root.
        !           173:             for I := SP downto T do N^[Stack[I]] := Infinity;
        !           174:             if SP <> T then       # Non-trivial SCC.
        !           175:                yield(V,EachUmember);
        !           176:             SP := T-1;
        !           177:             end;
        !           178:          end;
        !           179:       end;
        !           180: 
        !           181:    begin
        !           182:    Infinity := LastUnode+1;
        !           183:    new(N);
        !           184:    for T in EachUnode() do N^[T] := 0;  # for loops declare their
        !           185:    SP := 0;                             # control variable as a constant.
        !           186:    for V in EachUnodeUtoUsearch() do Search(V);
        !           187:    dispose(N);
        !           188:    end;
        !           189: 
        !           190: # Sample use of EachUSCC:
        !           191: 
        !           192: iterator EachUnodeUtoUsearch:node;
        !           193:    begin 
        !           194:    yield(1);
        !           195:    end;
        !           196: iterator EachUnode:node;
        !           197:    begin
        !           198:    yield(1); yield(2);
        !           199:    end;
        !           200: iterator R(V:node):node;
        !           201:    begin
        !           202:    if V = 1 then yield(2) else yield(1);
        !           203:    end;
        !           204: procedure Propagate(V,W:node); begin end;
        !           205: 
        !           206: procedure UseUEachUSCC;
        !           207:    begin
        !           208:    for (Root,EachUmember) in 
        !           209:        EachUSCC(EachUnode,EachUnodeUtoUsearch,R,Propagate,TakeUSCC,2) do
        !           210:       begin
        !           211:       writeln('Root of received SCC is ',Root);
        !           212:       writeln('Constituents of the SCC are:');
        !           213:       for I in EachUmember() do write(I);
        !           214:       writeln;
        !           215:       end;
        !           216:    end;
        !           217: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.